blob: 0613bf400afb632e266cccbb282b70f6203d0166 (
plain)
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
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
|
#
# Tests for code/scope commands
# ----------------------------------------------------------------------
# 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
package require itcl
# ----------------------------------------------------------------------
# Syntax of the "scope" command
# ----------------------------------------------------------------------
test scope-1.1 {scope command takes one argument} {
list [catch {itcl::scope} msg] $msg [catch {itcl::scope x y} msg] $msg
} {1 {wrong # args: should be "itcl::scope varname"} 1 {wrong # args: should be "itcl::scope varname"}}
test scope-1.2 {argument to scope command must be a variable} {
variable test_scope_var 0
list [catch {itcl::scope xyzzy} msg] $msg \
[catch {itcl::scope test_scope_var} msg] $msg
} {1 {variable "xyzzy" not found in namespace "::"} 0 ::test_scope_var}
test scope-1.3 {if variable is already fully qualified, scope does nothing} {
list [itcl::scope ::xyzzy] [itcl::scope ::test_scope_var]
} {::xyzzy ::test_scope_var}
test scope-1.4 {scope command returns fully qualified name} {
namespace eval test_scope_ns {
namespace eval child {
variable v1 0
itcl::scope v1
}
}
} {::test_scope_ns::child::v1}
namespace delete test_scope_ns
unset test_scope_var
# ----------------------------------------------------------------------
# Syntax of the "code" command
# ----------------------------------------------------------------------
test scope-2.1 {code command takes at least one argument} {
list [catch {itcl::code} msg] $msg
} {1 {wrong # args: should be "itcl::code ?-namespace name? command ?arg arg...?"}}
test scope-2.2 {code command with one argument} {
itcl::code arg1
} {namespace inscope :: arg1}
test scope-2.3 {code command with many arguments} {
list [itcl::code arg1 arg2] [itcl::code arg1 arg2 arg3 arg4]
} {{namespace inscope :: {arg1 arg2}} {namespace inscope :: {arg1 arg2 arg3 arg4}}}
test scope-2.4 {code command appends arguments as list elements} {
list [itcl::code "foo bar"] \
[itcl::code "foo bar" "hello, world!" "one, two, three"]
} {{namespace inscope :: {foo bar}} {namespace inscope :: {{foo bar} {hello, world!} {one, two, three}}}}
test scope-2.5 {code command inside code command} {
itcl::code [itcl::code arg1 arg2] arg3
} {namespace inscope :: {{namespace inscope :: {arg1 arg2}} arg3}}
test scope-2.6 {code command returns fully qualified names} {
namespace eval test_scope_ns {
namespace eval child {
itcl::code foo bar baz
}
}
} {namespace inscope ::test_scope_ns::child {foo bar baz}}
test scope-2.7 {code command lets you specify a namespace} {
list [catch {itcl::code -namespace xyzzy arg1 arg2} msg] $msg \
[catch {itcl::code -namespace test_scope_ns::child arg1 arg2} msg] $msg
} {1 {unknown namespace "xyzzy"} 0 {namespace inscope ::test_scope_ns::child {arg1 arg2}}}
test scope-2.8 {last namespace wins} {
itcl::code -namespace test_scope_ns::child -namespace test_scope_ns arg1
} {namespace inscope ::test_scope_ns arg1}
test scope-2.9 {"--" terminates switches} {
list [catch {itcl::code -namespace test_scope_ns -foo -bar} msg] $msg \
[catch {itcl::code -namespace test_scope_ns -- -foo -bar} msg] $msg
} {1 {bad option "-foo": should be -namespace or --} 0 {namespace inscope ::test_scope_ns {-foo -bar}}}
namespace delete test_scope_ns
# ----------------------------------------------------------------------
# Test code/scope commands in a class
# ----------------------------------------------------------------------
test scope-3.1 {define simple classes with things to export} {
itcl::class test_scope {
private variable priv "private-value"
protected variable prov "protected-value"
public variable pubv "public-value"
private common pric "private-common-value"
protected common proc "protected-common-value"
public common pubc "public-common-value"
variable varray
common carray
method mcontext {args} {
return [eval $args]
}
proc pcontext {args} {
return [eval $args]
}
private method prim {args} {
return "prim: $args"
}
protected method prom {args} {
return "prom: $args"
}
public method pubm {args} {
return "pubm: $args"
}
}
test_scope #auto
} {test_scope0}
test scope-3.2 {code command captures only class context} {
list [test_scope0 mcontext itcl::code arg1 arg2] \
[test_scope::pcontext itcl::code arg1 arg2]
} {{namespace inscope ::test_scope {arg1 arg2}} {namespace inscope ::test_scope {arg1 arg2}}}
test scope-3.3 {scope command captures class and object context} -body {
list [test_scope0 mcontext itcl::scope priv] \
[test_scope::pcontext itcl::scope pric]
} -match glob -result {::itcl::internal::variables::*::test_scope::priv ::itcl::internal::variables::test_scope::pric}
test scope-3.4 {scope command must recognize variable} {
list [catch {test_scope0 mcontext itcl::scope xyzzy} msg] $msg
} {1 {variable "xyzzy" not found in class "::test_scope"}}
test scope-3.5 {scope command provides access to instance variables} {
set result ""
foreach vname {priv prov pubv} {
lappend result [test_scope0 info variable $vname]
set var [test_scope0 mcontext itcl::scope $vname]
set $var "$vname-new"
lappend result [test_scope0 info variable $vname]
}
set result
} {{private variable ::test_scope::priv private-value private-value} {private variable ::test_scope::priv private-value priv-new} {protected variable ::test_scope::prov protected-value protected-value} {protected variable ::test_scope::prov protected-value prov-new} {public variable ::test_scope::pubv public-value {} public-value} {public variable ::test_scope::pubv public-value {} pubv-new}}
test scope-3.6 {scope command provides access to common variables} {
set result ""
foreach vname {pric proc pubc} {
lappend result [test_scope0 info variable $vname]
set var [test_scope0 mcontext itcl::scope $vname]
set $var "$vname-new"
lappend result [test_scope0 info variable $vname]
}
set result
} {{private common ::test_scope::pric private-common-value private-common-value} {private common ::test_scope::pric private-common-value pric-new} {protected common ::test_scope::proc protected-common-value protected-common-value} {protected common ::test_scope::proc protected-common-value proc-new} {public common ::test_scope::pubc public-common-value public-common-value} {public common ::test_scope::pubc public-common-value pubc-new}}
test scope-3.7 {code command provides access to methods} {
set result ""
foreach mname {prim prom pubm} {
set cmd [test_scope0 mcontext eval itcl::code \$this $mname]
lappend result $cmd [uplevel 0 $cmd 1 2 3]
}
set result
} {{namespace inscope ::test_scope {::test_scope0 prim}} {prim: 1 2 3} {namespace inscope ::test_scope {::test_scope0 prom}} {prom: 1 2 3} {namespace inscope ::test_scope {::test_scope0 pubm}} {pubm: 1 2 3}}
test scope-3.8 {scope command allows access to slots in an array} -body {
test_scope0 mcontext set varray(0) "defined"
test_scope::pcontext set carray(0) "defined"
list [catch {test_scope0 mcontext itcl::scope varray(0)} msg] $msg \
[catch {test_scope0 mcontext itcl::scope varray(1)} msg] $msg \
[catch {test_scope::pcontext itcl::scope carray(0)} msg] $msg \
[catch {test_scope::pcontext itcl::scope carray(1)} msg] $msg
} -match glob -result {0 ::itcl::internal::variables::*::test_scope::varray(0) 0 ::itcl::internal::variables::*::test_scope::varray(1) 0 ::itcl::internal::variables::test_scope::carray(0) 0 ::itcl::internal::variables::test_scope::carray(1)}
itcl::delete class test_scope
# ----------------------------------------------------------------------
# Test code/scope commands in a namespace
# ----------------------------------------------------------------------
test scope-4.1 {define simple namespace with things to export} {
namespace eval test_scope_ns {
variable array
proc pcontext {args} {
return [eval $args]
}
}
namespace children :: ::test_scope_ns
} {::test_scope_ns}
test scope-4.2 {scope command allows access to slots in an array} {
test_scope_ns::pcontext set array(0) "defined"
list [catch {test_scope_ns::pcontext itcl::scope array(0)} msg] $msg \
[catch {test_scope_ns::pcontext itcl::scope array(1)} msg] $msg
} {0 ::test_scope_ns::array(0) 0 ::test_scope_ns::array(1)}
namespace delete test_scope_ns
test scope-5.0 {Bug e5f529da75} -setup {
itcl::class B {
common c
method v {} {itcl::scope c}
}
itcl::class D {
inherit B
method v {} {itcl::scope c}
}
B b
D d
} -body {
string equal [b v] [d v]
} -cleanup {
itcl::delete class B
} -result 1
::tcltest::cleanupTests
return
|
