1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
#
# Tests for "auto_import" and autoloading facility
# ----------------------------------------------------------------------
# AUTHOR: Michael J. McLennan
# Bell Labs Innovations for Lucent Technologies
# mmclennan@lucent.com
# http://www.tcltk.com/itcl
# ----------------------------------------------------------------------
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
# ======================================================================
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2.2
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
set ::itcllib [lindex [lsearch -exact -index 1 -inline [info loaded] Itcl] 0]
# ----------------------------------------------------------------------
# Test "itcl::import::stub" command
# ----------------------------------------------------------------------
test import-1.1 {basic syntax for "stub" command} {
list [catch {itcl::import::stub} result] $result
} {1 {wrong # args: should be "itcl::import::stub subcommand ?arg ...?"}}
test import-1.1a {basic syntax for "stub" command
} -body {
list [catch {itcl::import::stub} result] $result
} -constraints {
needs_frq_1773103
} -result {1 {wrong # args: should be one of...
stub create name
stub exists name}}
test import-1.2 {"stub create" requires one argument} {
list [catch {itcl::import::stub create} result] $result \
[catch {itcl::import::stub create x y} result] $result
} {1 {wrong # args: should be "itcl::import::stub create name"} 1 {wrong # args: should be "itcl::import::stub create name"}}
test import-1.3 {"stub exists" requires one argument} {
list [catch {itcl::import::stub exists} result] $result \
[catch {itcl::import::stub exists x y} result] $result
} {1 {wrong # args: should be "itcl::import::stub exists name"} 1 {wrong # args: should be "itcl::import::stub exists name"}}
set interp [interp create]
$interp eval {set ::tcl::inl_mem_test 0}
$interp eval "
[list ::load $::itcllib Itcl]
[::tcltest::configure -load]
proc auto_load {cmd {namespace {}}} {
global debug
proc \$cmd {args} \[format {return \"%s: \$args\"} \$cmd\]
append debug \"(auto_load: \$cmd)\"
return 1
}
"
test import-1.4 {"stub create" creates a stub that triggers autoloading} {
$interp eval {
set debug ""
list [itcl::import::stub create foo::bar::test] \
[info commands ::foo::bar::test] \
[::foo::bar::test 1 2 3] \
$debug
}
} {{} ::foo::bar::test {::foo::bar::test: 1 2 3} {(auto_load: ::foo::bar::test)}}
test import-1.5 {"stub exists" recognizes stubs created by "stub create"} {
$interp eval {
set debug ""
itcl::import::stub create foo::bar::stub1
proc foo::bar::proc1 {{args {}}} {return "proc1: $args"}
list [itcl::import::stub exists foo::bar::stub1] \
[itcl::import::stub exists foo::bar::proc1]
}
} {1 0}
test import-1.6 {stubs can be autoloaded and replaced} {
$interp eval {
set debug ""
itcl::import::stub create foo::bar::stub2
list [itcl::import::stub exists foo::bar::stub2] \
[::foo::bar::stub2 a b c] \
[itcl::import::stub exists foo::bar::stub2] \
[::foo::bar::stub2 a b c] \
$debug
}
} {1 {::foo::bar::stub2: a b c} 0 {::foo::bar::stub2: a b c} {(auto_load: ::foo::bar::stub2)}}
catch {interp delete $interp}
# ----------------------------------------------------------------------
# Test "itcl::import::stub" command
# ----------------------------------------------------------------------
set interp [interp create]
$interp eval {set ::tcl::inl_mem_test 0}
$interp eval "
[list ::load $::itcllib Itcl]
[::tcltest::configure -load]
proc auto_load {cmd {namespace {}}} {
proc \$cmd {args} \[format {return \"%s: \$args\"} \$cmd\]
return 1
}
"
test import-2.1 {initialize some commands for autoloading} {
$interp eval {
namespace eval test {
namespace export foo*
}
itcl::import::stub create ::test::foo1
itcl::import::stub create ::test::foo2
lsort [info commands ::test::*]
}
} {::test::foo1 ::test::foo2}
test import-2.2 {stubs can be imported into other namespaces} {
$interp eval {
namespace eval user1 { namespace import ::test::* }
namespace eval user2 { namespace import ::test::* }
namespace eval user3 { namespace import ::test::* }
list [lsort [info commands ::user1::*]] \
[namespace origin ::user1::foo1] \
[namespace origin ::user1::foo2]
}
} {{::user1::foo1 ::user1::foo2} ::test::foo1 ::test::foo2}
test import-2.3 {stubs can be autoloaded and imported links remain} {
$interp eval {
list [::user1::foo1 1 2 3 4] \
[namespace origin ::user1::foo1] \
[namespace origin ::user2::foo1] \
[namespace origin ::user3::foo1] \
[itcl::import::stub exists ::test::foo1]
}
} {{::test::foo1: 1 2 3 4} ::test::foo1 ::test::foo1 ::test::foo1 0}
test import-2.4 {itcl::class handles stubs correctly
} -body {
$interp eval {
proc auto_load {cmd {namespace {}}} {
itcl::class $cmd { }
return 1
}
list [::user2::foo2 x] \
[x info class] \
[namespace origin ::user1::foo2] \
[namespace origin ::user2::foo2] \
[namespace origin ::user3::foo2] \
[itcl::import::stub exists ::test::foo2]
}
} -constraints {
only_working_in_itcl3.4
} -result {x ::test::foo2 ::test::foo2 ::test::foo2 ::test::foo2 0}
test import-2.5 {itcl::class will overwrite stubs in an existing namespace} {
$interp eval {
proc auto_load {cmd {namespace {}}} {
itcl::class $cmd { }
return 1
}
namespace eval test::buried { }
itcl::import::stub create ::test::buried
itcl::import::stub create ::test::buried::stub
list [catch {::test::buried xx} result] $result [xx info class]
}
} {0 xx ::test::buried}
test import-2.6 {itcl::class will overwrite stubs} {
$interp eval {
proc auto_load {cmd {namespace {}}} {
itcl::class $cmd { }
return 1
}
itcl::import::stub create ::test::zonk
list [catch {::test::zonk yy} result] $result [yy info class]
}
} {0 yy ::test::zonk}
catch {interp delete $interp}
::tcltest::cleanupTests
return
|
