URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [itcl/] [itcl/] [tests/] [basic.test] - Blame information for rev 1773

Go to most recent revision | Details | Compare with Previous | View Log


#
# Basic tests for class definition and method/proc access
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            mmclennan@lucent.com
#            http://www.tcltk.com/itcl
#
#      RCS:  $Id: basic.test,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $
# ----------------------------------------------------------------------
#            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.
 
if {[string compare test [info procs test]] == 1} then {source defs}
 
# ----------------------------------------------------------------------
#  Simple class definition
# ----------------------------------------------------------------------
test basic-1.1 {define a simple class} {
    itcl::class Counter {
        constructor {args} {
            incr num
            eval configure $args
        }
        destructor {
            incr num -1
        }
 
        method ++ {} {
            return [incr val $by]
        }
        proc num {} {
            return $num
        }
        public variable by 1
        protected variable val 0
        private common num 0
    }
} ""
 
test basic-1.2 {class is now defined} {
    find classes Counter
} {Counter}
 
test basic-1.3 {access command exists with class name} {
    namespace which -command Counter
} {::Counter}
 
test basic-1.4 {create a simple object} {
    Counter x
} {x}
 
test basic-1.5a {object names cannot be duplicated} {
    list [catch "Counter x" msg] $msg
} {1 {command "x" already exists in namespace "::"}}
 
test basic-1.5b {built-in commands cannot be clobbered} {
    list [catch "Counter info" msg] $msg
} {1 {command "info" already exists in namespace "::"}}
 
test basic-1.6 {objects have an access command} {
    namespace which -command x
} {::x}
 
test basic-1.7a {objects are added to the master list} {
    find objects x
} {x}
 
test basic-1.7b {objects are added to the master list} {
    find objects -class Counter x
} {x}
 
test basic-1.8 {objects can be deleted} {
    list [delete object x] [namespace which -command x]
} {{} {}}
 
test basic-1.9 {objects can be recreated with the same name} {
    Counter x
} {x}
 
test basic-1.10 {objects can be destroyed by deleting their access command} {
    rename ::x ""
    find objects x
} {}
 
# ----------------------------------------------------------------------
#  #auto names
# ----------------------------------------------------------------------
test basic-2.1 {create an object with an automatic name} {
    Counter #auto
} {counter0}
 
test basic-2.2 {bury "#auto" within object name} {
    Counter x#autoy
} {xcounter1y}
 
test basic-2.3 {bury "#auto" within object name} {
    Counter a#aut#autob
} {a#autcounter2b}
 
test basic-2.4 {"#auto" is smart enough to skip names that are taken} {
    Counter counter3
    Counter #auto
} {counter4}
 
# ----------------------------------------------------------------------
#  Simple object use
# ----------------------------------------------------------------------
test basic-3.1 {object access command works} {
    Counter c
    list [c ++] [c ++] [c ++]
} {1 2 3}
 
test basic-3.2 {errors produce usage info} {
    list [catch "c xyzzy" msg] $msg
} {1 {bad option "xyzzy": should be one of...
  c ++
  c cget -option
  c configure ?-option? ?value -option value...?
  c isa className}}
 
test basic-3.3 {built-in configure can query public variables} {
    c configure
} {{-by 1 1}}
 
test basic-3.4 {built-in configure can query one public variable} {
    c configure -by
} {-by 1 1}
 
test basic-3.5 {built-in configure can set public variable} {
    list [c configure -by 2] [c cget -by]
} {{} 2}
 
test basic-3.6 {configure actually changes public variable} {
    list [c ++] [c ++]
} {5 7}
 
test basic-3.7 {class procs can be accessed} {
    Counter::num
} {6}
 
test basic-3.8 {obsolete syntax is no longer allowed} {
    list [catch "Counter :: num" msg] $msg
} {1 {syntax "class :: proc" is an anachronism
[incr Tcl] no longer supports this syntax.
Instead, remove the spaces from your procedure invocations:
  Counter::num ?args?}}
 
# ----------------------------------------------------------------------
#  Classes can be destroyed and redefined
# ----------------------------------------------------------------------
test basic-4.1 {classes can be destroyed} {
    list [delete class Counter] \
         [find classes Counter] \
         [namespace children :: Counter] \
         [namespace which -command Counter]
} {{} {} {} {}}
 
test basic-4.2 {classes can be redefined} {
    itcl::class Counter {
        method ++ {} {
            return [incr val $by]
        }
        public variable by 1
        protected variable val 0
    }
} {}
 
test basic-4.3 {the redefined class is actually different} {
    list [catch "Counter::num" msg] $msg
} {1 {invalid command name "Counter::num"}}
 
test basic-4.4 {objects can be created from the new class} {
    list [Counter #auto] [Counter #auto]
} {counter0 counter1}
 
test basic-4.5 {when a class is destroyed, its objects are deleted} {
    list [lsort [find objects counter*]] \
         [delete class Counter] \
         [lsort [find objects counter*]]
} {{counter0 counter1} {} {}}
 
# ----------------------------------------------------------------------
#  Namespace variables
# ----------------------------------------------------------------------
test basic-5.1 {define a simple class with variables in the namespace} {
    itcl::class test_globals {
        common g1 "global1"
        proc getval {name} {
            variable $name
            return [set [namespace tail $name]]
        }
        proc setval {name val} {
            variable $name
            return [set [namespace tail $name] $val]
        }
        method do {args} {
            return [eval $args]
        }
    }
    namespace eval test_globals {
        variable g2 "global2"
    }
} ""
 
test basic-5.2 {create an object for the tests} {
    test_globals #auto
} {test_globals0}
 
test basic-5.3 {common variables live in the namespace} {
    lsort [info vars ::test_globals::*]
} {::test_globals::g1 ::test_globals::g2}
 
test basic-5.4 {common variables can be referenced transparently} {
    list [catch {test_globals0 do set g1} msg] $msg
} {0 global1}
 
test basic-5.5 {namespace variables require a declaration} {
    list [catch {test_globals0 do set g2} msg] $msg
} {1 {can't read "g2": no such variable}}
 
test basic-5.6a {variable accesses variables within namespace} {
    list [catch {test_globals::getval g1} msg] $msg
} {0 global1}
 
test basic-5.6a {variable accesses variables within namespace} {
    list [catch {test_globals::getval g2} msg] $msg
} {0 global2}
 
test basic-5.7 {variable command will not find vars in other namespaces} {
    set ::test_global_0 "g0"
    list [catch {test_globals::getval test_global_0} msg] $msg \
         [catch {test_globals::getval ::test_global_0} msg] $msg \
} {1 {can't read "test_global_0": no such variable} 0 g0}
 
test basic-5.8 {to create globals in a namespace, use the full path} {
    test_globals::setval ::test_global_1 g1
    namespace eval :: {lsort [info globals test_global_*]}
} {test_global_0 test_global_1}
 
test basic-5.9 {variable names can have ":" in them} {
    test_globals::setval ::test:global:2 g2
    namespace eval :: {info globals test:global:2}
} {test:global:2}
 
# ----------------------------------------------------------------------
#  Array variables
# ----------------------------------------------------------------------
test basic-6.1 {set up a class definition with array variables} {
    proc test_arrays_get {name} {
        upvar $name x
        set rlist {}
        foreach index [lsort [array names x]] {
            lappend rlist [list $index $x($index)]
        }
        return $rlist
    }
    itcl::class test_arrays {
        variable nums
        common undefined
 
        common colors
        set colors(red)   #ff0000
        set colors(green) #00ff00
        set colors(blue)  #0000ff
 
        constructor {} {
            set nums(one) 1
            set nums(two) 2
            set nums(three) 3
 
            set undefined(a) A
            set undefined(b) B
        }
        method do {args} {
            return [eval $args]
        }
    }
    test_arrays #auto
} {test_arrays0}
 
test basic-6.2 {test array access for instance variables} {
    lsort [test_arrays0 do array get nums]
} {1 2 3 one three two}
 
test basic-6.3 {test array access for commons} {
    lsort [test_arrays0 do array get colors]
} {#0000ff #00ff00 #ff0000 blue green red}
 
test basic-6.4 {test array access for instance variables via "upvar"} {
    test_arrays0 do test_arrays_get nums
} {{one 1} {three 3} {two 2}}
 
test basic-6.5 {test array access for commons via "upvar"} {
    test_arrays0 do test_arrays_get colors
} {{blue #0000ff} {green #00ff00} {red #ff0000}}
 
test basic-6.6a {test array access for commons defined in constructor} {
    lsort [test_arrays0 do array get undefined]
} {A B a b}
 
test basic-6.6b {test array access for commons defined in constructor} {
    test_arrays0 do test_arrays_get undefined
} {{a A} {b B}}
 
test basic-6.6c {test array access for commons defined in constructor} {
    list [test_arrays0 do set undefined(a)] [test_arrays0 do set undefined(b)]
} {A B}
 
test basic-6.7 {common variables can be unset} {
    test_arrays0 do unset undefined
    test_arrays0 do array names undefined
} {}
 
test basic-6.8 {common variables can be redefined} {
    test_arrays0 do set undefined "scalar"
} {scalar}

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [itcl/] [itcl/] [tests/] [basic.test] - Blame information for rev 1773

Line No.	Rev	Author	Line
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}`