1 |
578 |
markom |
#
|
2 |
|
|
# Basic tests for class definition and method/proc access
|
3 |
|
|
# ----------------------------------------------------------------------
|
4 |
|
|
# AUTHOR: Michael J. McLennan
|
5 |
|
|
# Bell Labs Innovations for Lucent Technologies
|
6 |
|
|
# mmclennan@lucent.com
|
7 |
|
|
# http://www.tcltk.com/itcl
|
8 |
|
|
#
|
9 |
|
|
# RCS: $Id: basic.test,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $
|
10 |
|
|
# ----------------------------------------------------------------------
|
11 |
|
|
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
12 |
|
|
# ======================================================================
|
13 |
|
|
# See the file "license.terms" for information on usage and
|
14 |
|
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
15 |
|
|
|
16 |
|
|
if {[string compare test [info procs test]] == 1} then {source defs}
|
17 |
|
|
|
18 |
|
|
# ----------------------------------------------------------------------
|
19 |
|
|
# Simple class definition
|
20 |
|
|
# ----------------------------------------------------------------------
|
21 |
|
|
test basic-1.1 {define a simple class} {
|
22 |
|
|
itcl::class Counter {
|
23 |
|
|
constructor {args} {
|
24 |
|
|
incr num
|
25 |
|
|
eval configure $args
|
26 |
|
|
}
|
27 |
|
|
destructor {
|
28 |
|
|
incr num -1
|
29 |
|
|
}
|
30 |
|
|
|
31 |
|
|
method ++ {} {
|
32 |
|
|
return [incr val $by]
|
33 |
|
|
}
|
34 |
|
|
proc num {} {
|
35 |
|
|
return $num
|
36 |
|
|
}
|
37 |
|
|
public variable by 1
|
38 |
|
|
protected variable val 0
|
39 |
|
|
private common num 0
|
40 |
|
|
}
|
41 |
|
|
} ""
|
42 |
|
|
|
43 |
|
|
test basic-1.2 {class is now defined} {
|
44 |
|
|
find classes Counter
|
45 |
|
|
} {Counter}
|
46 |
|
|
|
47 |
|
|
test basic-1.3 {access command exists with class name} {
|
48 |
|
|
namespace which -command Counter
|
49 |
|
|
} {::Counter}
|
50 |
|
|
|
51 |
|
|
test basic-1.4 {create a simple object} {
|
52 |
|
|
Counter x
|
53 |
|
|
} {x}
|
54 |
|
|
|
55 |
|
|
test basic-1.5a {object names cannot be duplicated} {
|
56 |
|
|
list [catch "Counter x" msg] $msg
|
57 |
|
|
} {1 {command "x" already exists in namespace "::"}}
|
58 |
|
|
|
59 |
|
|
test basic-1.5b {built-in commands cannot be clobbered} {
|
60 |
|
|
list [catch "Counter info" msg] $msg
|
61 |
|
|
} {1 {command "info" already exists in namespace "::"}}
|
62 |
|
|
|
63 |
|
|
test basic-1.6 {objects have an access command} {
|
64 |
|
|
namespace which -command x
|
65 |
|
|
} {::x}
|
66 |
|
|
|
67 |
|
|
test basic-1.7a {objects are added to the master list} {
|
68 |
|
|
find objects x
|
69 |
|
|
} {x}
|
70 |
|
|
|
71 |
|
|
test basic-1.7b {objects are added to the master list} {
|
72 |
|
|
find objects -class Counter x
|
73 |
|
|
} {x}
|
74 |
|
|
|
75 |
|
|
test basic-1.8 {objects can be deleted} {
|
76 |
|
|
list [delete object x] [namespace which -command x]
|
77 |
|
|
} {{} {}}
|
78 |
|
|
|
79 |
|
|
test basic-1.9 {objects can be recreated with the same name} {
|
80 |
|
|
Counter x
|
81 |
|
|
} {x}
|
82 |
|
|
|
83 |
|
|
test basic-1.10 {objects can be destroyed by deleting their access command} {
|
84 |
|
|
rename ::x ""
|
85 |
|
|
find objects x
|
86 |
|
|
} {}
|
87 |
|
|
|
88 |
|
|
# ----------------------------------------------------------------------
|
89 |
|
|
# #auto names
|
90 |
|
|
# ----------------------------------------------------------------------
|
91 |
|
|
test basic-2.1 {create an object with an automatic name} {
|
92 |
|
|
Counter #auto
|
93 |
|
|
} {counter0}
|
94 |
|
|
|
95 |
|
|
test basic-2.2 {bury "#auto" within object name} {
|
96 |
|
|
Counter x#autoy
|
97 |
|
|
} {xcounter1y}
|
98 |
|
|
|
99 |
|
|
test basic-2.3 {bury "#auto" within object name} {
|
100 |
|
|
Counter a#aut#autob
|
101 |
|
|
} {a#autcounter2b}
|
102 |
|
|
|
103 |
|
|
test basic-2.4 {"#auto" is smart enough to skip names that are taken} {
|
104 |
|
|
Counter counter3
|
105 |
|
|
Counter #auto
|
106 |
|
|
} {counter4}
|
107 |
|
|
|
108 |
|
|
# ----------------------------------------------------------------------
|
109 |
|
|
# Simple object use
|
110 |
|
|
# ----------------------------------------------------------------------
|
111 |
|
|
test basic-3.1 {object access command works} {
|
112 |
|
|
Counter c
|
113 |
|
|
list [c ++] [c ++] [c ++]
|
114 |
|
|
} {1 2 3}
|
115 |
|
|
|
116 |
|
|
test basic-3.2 {errors produce usage info} {
|
117 |
|
|
list [catch "c xyzzy" msg] $msg
|
118 |
|
|
} {1 {bad option "xyzzy": should be one of...
|
119 |
|
|
c ++
|
120 |
|
|
c cget -option
|
121 |
|
|
c configure ?-option? ?value -option value...?
|
122 |
|
|
c isa className}}
|
123 |
|
|
|
124 |
|
|
test basic-3.3 {built-in configure can query public variables} {
|
125 |
|
|
c configure
|
126 |
|
|
} {{-by 1 1}}
|
127 |
|
|
|
128 |
|
|
test basic-3.4 {built-in configure can query one public variable} {
|
129 |
|
|
c configure -by
|
130 |
|
|
} {-by 1 1}
|
131 |
|
|
|
132 |
|
|
test basic-3.5 {built-in configure can set public variable} {
|
133 |
|
|
list [c configure -by 2] [c cget -by]
|
134 |
|
|
} {{} 2}
|
135 |
|
|
|
136 |
|
|
test basic-3.6 {configure actually changes public variable} {
|
137 |
|
|
list [c ++] [c ++]
|
138 |
|
|
} {5 7}
|
139 |
|
|
|
140 |
|
|
test basic-3.7 {class procs can be accessed} {
|
141 |
|
|
Counter::num
|
142 |
|
|
} {6}
|
143 |
|
|
|
144 |
|
|
test basic-3.8 {obsolete syntax is no longer allowed} {
|
145 |
|
|
list [catch "Counter :: num" msg] $msg
|
146 |
|
|
} {1 {syntax "class :: proc" is an anachronism
|
147 |
|
|
[incr Tcl] no longer supports this syntax.
|
148 |
|
|
Instead, remove the spaces from your procedure invocations:
|
149 |
|
|
Counter::num ?args?}}
|
150 |
|
|
|
151 |
|
|
# ----------------------------------------------------------------------
|
152 |
|
|
# Classes can be destroyed and redefined
|
153 |
|
|
# ----------------------------------------------------------------------
|
154 |
|
|
test basic-4.1 {classes can be destroyed} {
|
155 |
|
|
list [delete class Counter] \
|
156 |
|
|
[find classes Counter] \
|
157 |
|
|
[namespace children :: Counter] \
|
158 |
|
|
[namespace which -command Counter]
|
159 |
|
|
} {{} {} {} {}}
|
160 |
|
|
|
161 |
|
|
test basic-4.2 {classes can be redefined} {
|
162 |
|
|
itcl::class Counter {
|
163 |
|
|
method ++ {} {
|
164 |
|
|
return [incr val $by]
|
165 |
|
|
}
|
166 |
|
|
public variable by 1
|
167 |
|
|
protected variable val 0
|
168 |
|
|
}
|
169 |
|
|
} {}
|
170 |
|
|
|
171 |
|
|
test basic-4.3 {the redefined class is actually different} {
|
172 |
|
|
list [catch "Counter::num" msg] $msg
|
173 |
|
|
} {1 {invalid command name "Counter::num"}}
|
174 |
|
|
|
175 |
|
|
test basic-4.4 {objects can be created from the new class} {
|
176 |
|
|
list [Counter #auto] [Counter #auto]
|
177 |
|
|
} {counter0 counter1}
|
178 |
|
|
|
179 |
|
|
test basic-4.5 {when a class is destroyed, its objects are deleted} {
|
180 |
|
|
list [lsort [find objects counter*]] \
|
181 |
|
|
[delete class Counter] \
|
182 |
|
|
[lsort [find objects counter*]]
|
183 |
|
|
} {{counter0 counter1} {} {}}
|
184 |
|
|
|
185 |
|
|
# ----------------------------------------------------------------------
|
186 |
|
|
# Namespace variables
|
187 |
|
|
# ----------------------------------------------------------------------
|
188 |
|
|
test basic-5.1 {define a simple class with variables in the namespace} {
|
189 |
|
|
itcl::class test_globals {
|
190 |
|
|
common g1 "global1"
|
191 |
|
|
proc getval {name} {
|
192 |
|
|
variable $name
|
193 |
|
|
return [set [namespace tail $name]]
|
194 |
|
|
}
|
195 |
|
|
proc setval {name val} {
|
196 |
|
|
variable $name
|
197 |
|
|
return [set [namespace tail $name] $val]
|
198 |
|
|
}
|
199 |
|
|
method do {args} {
|
200 |
|
|
return [eval $args]
|
201 |
|
|
}
|
202 |
|
|
}
|
203 |
|
|
namespace eval test_globals {
|
204 |
|
|
variable g2 "global2"
|
205 |
|
|
}
|
206 |
|
|
} ""
|
207 |
|
|
|
208 |
|
|
test basic-5.2 {create an object for the tests} {
|
209 |
|
|
test_globals #auto
|
210 |
|
|
} {test_globals0}
|
211 |
|
|
|
212 |
|
|
test basic-5.3 {common variables live in the namespace} {
|
213 |
|
|
lsort [info vars ::test_globals::*]
|
214 |
|
|
} {::test_globals::g1 ::test_globals::g2}
|
215 |
|
|
|
216 |
|
|
test basic-5.4 {common variables can be referenced transparently} {
|
217 |
|
|
list [catch {test_globals0 do set g1} msg] $msg
|
218 |
|
|
} {0 global1}
|
219 |
|
|
|
220 |
|
|
test basic-5.5 {namespace variables require a declaration} {
|
221 |
|
|
list [catch {test_globals0 do set g2} msg] $msg
|
222 |
|
|
} {1 {can't read "g2": no such variable}}
|
223 |
|
|
|
224 |
|
|
test basic-5.6a {variable accesses variables within namespace} {
|
225 |
|
|
list [catch {test_globals::getval g1} msg] $msg
|
226 |
|
|
} {0 global1}
|
227 |
|
|
|
228 |
|
|
test basic-5.6a {variable accesses variables within namespace} {
|
229 |
|
|
list [catch {test_globals::getval g2} msg] $msg
|
230 |
|
|
} {0 global2}
|
231 |
|
|
|
232 |
|
|
test basic-5.7 {variable command will not find vars in other namespaces} {
|
233 |
|
|
set ::test_global_0 "g0"
|
234 |
|
|
list [catch {test_globals::getval test_global_0} msg] $msg \
|
235 |
|
|
[catch {test_globals::getval ::test_global_0} msg] $msg \
|
236 |
|
|
} {1 {can't read "test_global_0": no such variable} 0 g0}
|
237 |
|
|
|
238 |
|
|
test basic-5.8 {to create globals in a namespace, use the full path} {
|
239 |
|
|
test_globals::setval ::test_global_1 g1
|
240 |
|
|
namespace eval :: {lsort [info globals test_global_*]}
|
241 |
|
|
} {test_global_0 test_global_1}
|
242 |
|
|
|
243 |
|
|
test basic-5.9 {variable names can have ":" in them} {
|
244 |
|
|
test_globals::setval ::test:global:2 g2
|
245 |
|
|
namespace eval :: {info globals test:global:2}
|
246 |
|
|
} {test:global:2}
|
247 |
|
|
|
248 |
|
|
# ----------------------------------------------------------------------
|
249 |
|
|
# Array variables
|
250 |
|
|
# ----------------------------------------------------------------------
|
251 |
|
|
test basic-6.1 {set up a class definition with array variables} {
|
252 |
|
|
proc test_arrays_get {name} {
|
253 |
|
|
upvar $name x
|
254 |
|
|
set rlist {}
|
255 |
|
|
foreach index [lsort [array names x]] {
|
256 |
|
|
lappend rlist [list $index $x($index)]
|
257 |
|
|
}
|
258 |
|
|
return $rlist
|
259 |
|
|
}
|
260 |
|
|
itcl::class test_arrays {
|
261 |
|
|
variable nums
|
262 |
|
|
common undefined
|
263 |
|
|
|
264 |
|
|
common colors
|
265 |
|
|
set colors(red) #ff0000
|
266 |
|
|
set colors(green) #00ff00
|
267 |
|
|
set colors(blue) #0000ff
|
268 |
|
|
|
269 |
|
|
constructor {} {
|
270 |
|
|
set nums(one) 1
|
271 |
|
|
set nums(two) 2
|
272 |
|
|
set nums(three) 3
|
273 |
|
|
|
274 |
|
|
set undefined(a) A
|
275 |
|
|
set undefined(b) B
|
276 |
|
|
}
|
277 |
|
|
method do {args} {
|
278 |
|
|
return [eval $args]
|
279 |
|
|
}
|
280 |
|
|
}
|
281 |
|
|
test_arrays #auto
|
282 |
|
|
} {test_arrays0}
|
283 |
|
|
|
284 |
|
|
test basic-6.2 {test array access for instance variables} {
|
285 |
|
|
lsort [test_arrays0 do array get nums]
|
286 |
|
|
} {1 2 3 one three two}
|
287 |
|
|
|
288 |
|
|
test basic-6.3 {test array access for commons} {
|
289 |
|
|
lsort [test_arrays0 do array get colors]
|
290 |
|
|
} {#0000ff #00ff00 #ff0000 blue green red}
|
291 |
|
|
|
292 |
|
|
test basic-6.4 {test array access for instance variables via "upvar"} {
|
293 |
|
|
test_arrays0 do test_arrays_get nums
|
294 |
|
|
} {{one 1} {three 3} {two 2}}
|
295 |
|
|
|
296 |
|
|
test basic-6.5 {test array access for commons via "upvar"} {
|
297 |
|
|
test_arrays0 do test_arrays_get colors
|
298 |
|
|
} {{blue #0000ff} {green #00ff00} {red #ff0000}}
|
299 |
|
|
|
300 |
|
|
test basic-6.6a {test array access for commons defined in constructor} {
|
301 |
|
|
lsort [test_arrays0 do array get undefined]
|
302 |
|
|
} {A B a b}
|
303 |
|
|
|
304 |
|
|
test basic-6.6b {test array access for commons defined in constructor} {
|
305 |
|
|
test_arrays0 do test_arrays_get undefined
|
306 |
|
|
} {{a A} {b B}}
|
307 |
|
|
|
308 |
|
|
test basic-6.6c {test array access for commons defined in constructor} {
|
309 |
|
|
list [test_arrays0 do set undefined(a)] [test_arrays0 do set undefined(b)]
|
310 |
|
|
} {A B}
|
311 |
|
|
|
312 |
|
|
test basic-6.7 {common variables can be unset} {
|
313 |
|
|
test_arrays0 do unset undefined
|
314 |
|
|
test_arrays0 do array names undefined
|
315 |
|
|
} {}
|
316 |
|
|
|
317 |
|
|
test basic-6.8 {common variables can be redefined} {
|
318 |
|
|
test_arrays0 do set undefined "scalar"
|
319 |
|
|
} {scalar}
|