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
|
#
# 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.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
# ----------------------------------------------------------------------
# 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 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 [subst -novariables {
[::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 [subst -novariables {
[::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} {
$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]
}
} {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 {
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}
catch {interp delete $interp}
::tcltest::cleanupTests
return
|
