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

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [itcl/] [itcl/] [tests/] [old/] [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.
 
# ----------------------------------------------------------------------
#  CLEAN THE SLATE
# ----------------------------------------------------------------------
foreach obj [itcl_info objects -class Foo] {
        $obj delete
}
 
# ----------------------------------------------------------------------
#  CREATING OBJECTS
# ----------------------------------------------------------------------
test {Create a simple object} {
        Foo x
} {
        $result == "x"
}
 
test {Make sure that object names cannot be duplicated} {
        catch "Foo x" errmsg
} {
        $result == 1
}
 
test {Create another object} {
        Foo xx
} {
        $result == "xx"
}
 
test {Create an object with an automatic name} {
        Foo #auto
} {
        [string match foo* $result]
}
 
test {Get list of objects in a class} {
        itcl_info objects -class Foo
} {
        [llength $result] == 3
}
 
# ----------------------------------------------------------------------
#  PUBLIC VARIABLES
# ----------------------------------------------------------------------
test {Info: all public variables} {
        x info public
} {
        [test_cmp_lists $result {Foo::blit Foo::blat Foo::blot}]
}
 
test {Info: public variable initial value} {
        x info public blit -init
} {
        $result == ""
}
 
test {Info: public variable initial value (undefined)} {
        x info public blit -value
} {
        $result == ""
}
 
test {Info: public variable initial value} {
        x info public blat -init
} {
        $result == 0
}
 
test {Info: public variable current value} {
        x info public blot -value
} {
        $result == 1
}
 
test {Info: public variable config statement} {
        x info public blit -config
} {
        $result == ""
}
 
test {Info: public variable config statement} {
        x info public blot -config
} {
        $result == {global WATCH; set WATCH "blot=$blot"}
}
 
# ----------------------------------------------------------------------
#  CONFIG-ING PUBLIC VARIABLES
# ----------------------------------------------------------------------
test {Setting public variables via "config"} {
        x config -blit 27 -blat xyz
} {
        $result == "Foo::blit Foo::blat"
}
 
test {Info: public variable init/current value} {
        x info public blit -init -value
} {
        $result == {{} 27}
}
 
test {Info: public variable init/current value} {
        x info public blat -init -value
} {
        $result == {0 xyz}
}
 
test {"config" is ordinary arg if it is not last arg} {
        x configx -blit pdq
} {
        $result == {-blit|pdq}
}
 
test {Public variables with "config" code} {
        set WATCH ""
        concat [x config -blot abc] / $WATCH
} {
        $result == "Foo::blot / blot=abc"
}
 
test {Make sure object data is local to objects} {
        x config -blit abc
        xx config -blit xyz
        concat [x info public blit -value] / [xx info public blit -value]
} {
        $result == "abc / xyz"
}
 
# ----------------------------------------------------------------------
#  PROTECTED VARIABLES
# ----------------------------------------------------------------------
test {Info: all protected variables} {
        x info protected
} {
        [test_cmp_lists $result {Foo::_blit Foo::_blat Foo::this}]
}
 
test {Info: protected "this" variable} {
        x info protected this -value
} {
        $result == "::x"
}
 
test {Info: protected "this" variable} {
        xx info protected this -value
} {
        $result == "::xx"
}
 
test {Info: protected variable initial value} {
        x info protected _blit -init
} {
        $result == ""
}
 
test {Info: protected variable access/value} {
        x do {set _blit rst}
} {
        $result == "Foo says 'rst'" &&
        [x info protected _blit -value] == "rst"
}
 
# ----------------------------------------------------------------------
#  COMMON VARIABLES
# ----------------------------------------------------------------------
test {Info: all protected variables} {
        x info common
} {
        [test_cmp_lists $result {Foo::foos Foo::nfoo}]
}
 
test {Info: common variable initial value} {
        x info common foos -init
} {
        $result == ""
}
 
test {Info: common variable initial value} {
        x info common nfoo -init
} {
        $result == 0
}
 
test {Info: common variable access/value} {
        x do {set nfoo 999}
        x info common nfoo -value
} {
        $result == 999
}
 
test {Make sure common data is really common} {
        x do {set nfoo 0}
        x info common nfoo -value
} {
        $result == [xx info common nfoo -value]
}
 
test {Access common data in proc} {
        x do {set nfoo 10}
        Foo :: nfoos
} {
        $result == 10
}
 
test {Common variables can be initialized within class definition} {
        x do {if {[info exists foos(_ignore_)]} {set foos(_ignore_)}}
} {
        $result == "Foo says 'foos-is-now-an-array'"
}
 
test {Arrays as common data} {
        Foo :: foos
} {
        [test_cmp_lists $result [itcl_info objects -class Foo]]
}
 
# ----------------------------------------------------------------------
#  METHODS
# ----------------------------------------------------------------------
test {Info: all methods} {
        x info method
} {
        [test_cmp_lists $result {
                Foo::constructor Foo::destructor
                Foo::nothing Foo::do Foo::xecho
                Foo::config Foo::xconfig Foo::configx
                Foo::testMethodArgs
                Foo::configure Foo::delete Foo::cget Foo::isa
        }]
}
 
test {Info: method args} {
        x info method nothing -args
} {
        $result == ""
}
 
test {Info: method args} {
        x info method xconfig -args
} {
        $result == "x config"
}
 
test {Info: method body} {
        x info method nothing -body
} {
        $result == ""
}
 
test {Info: method body} {
        x info method xconfig -body
} {
        $result == {
                return "$x|$config"
        }
}
 
# ----------------------------------------------------------------------
#  PROCS
# ----------------------------------------------------------------------
test {Info: all procs} {
        x info proc
} {
        [test_cmp_lists $result {
                Foo::echo Foo::foos Foo::nfoos Foo::testProcArgs
        }]
}
 
test {Info: proc args} {
        x info proc nfoos -args
} {
        $result == ""
}
 
test {Info: proc args} {
        x info proc foos -args
} {
        $result == "{pattern *}"
}
 
test {Info: proc body} {
        x info proc nfoos -body
} {
        $result == {
                return $nfoo
        }
}
 
test {Info: proc body} {
        x info body nfoos
} {
        $result == {
                return $nfoo
        }
}
 
# ----------------------------------------------------------------------
#  ARGUMENT LISTS
# ----------------------------------------------------------------------
test {Default arguments can get assigned a proper value} {
        Foo :: foos x*
} {
        [test_cmp_lists $result {x xx}]
}
 
test {Default value for "config" argument} {
        x config
} {
        $result == "Foo::blit Foo::blat" &&
        [x info public blit -value] == "auto" &&
        [x info public blat -value] == "matic"
}
 
test {"args" formal argument absorbs extra arguments} {
        Foo :: echo abc 1 2 3
} {
        $result == "abc | 3: 1 2 3"
}
 
test {"args" formal argument absorbs extra arguments} {
        Foo :: echo def
} {
        $result == "def | 0: "
}
 
test {"args" formal argument absorbs extra arguments} {
        x xecho abc 1 2 3
} {
        $result == "abc | 3: 1 2 3"
}
 
test {"args" formal argument absorbs extra arguments} {
        x xecho def
} {
        $result == "def | 0: "
}
 
test {Extra args cause an error} {
        catch "x configx arg arg error"
} {
        $result != 0
}
 
test {Extra args cause an error} {
        catch "x nothing error"
} {
        $result != 0
}
 
test {Formal arguments don't clobber public/protected variables} {
        x do {
                set blit okay
                set _blit no-problem
        }
        x testMethodArgs yuck puke etc.
} {
        $result == "yuck, puke, and 1 other args" &&
        [x info public blit -value] == "okay" &&
        [x info protected _blit -value] == "no-problem"
}
 
test {Formal arguments don't clobber common variables} {
        Foo :: testProcArgs yuck etc.
} {
        $result == "yuck, and 1 other args" &&
        [x info common nfoo -value] != "yuck"
}
 
# ----------------------------------------------------------------------
#  DELETING OBJECTS
# ----------------------------------------------------------------------
test {Delete an object} {
        x delete
} {
        $result == ""
}
 
test {Delete an object} {
        xx delete
} {
        $result == ""
}
 
test {Destructor is properly invoked} {
        Foo :: foos
} {
        [test_cmp_lists $result [itcl_info objects -class Foo]]
}
 
test {Object names are removed as commands} {
        expr {[info commands x] == "" && [info commands xx] == ""}
} {
        $result == 1
}

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [itcl/] [itcl/] [tests/] [old/] [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			`# ----------------------------------------------------------------------`
17			`# CLEAN THE SLATE`
18			`# ----------------------------------------------------------------------`
19			`foreach obj [itcl_info objects -class Foo] {`
20			`$obj delete`
21			`}`
22
23			`# ----------------------------------------------------------------------`
24			`# CREATING OBJECTS`
25			`# ----------------------------------------------------------------------`
26			`test {Create a simple object} {`
27			`Foo x`
28			`} {`
29			`$result == "x"`
30			`}`
31
32			`test {Make sure that object names cannot be duplicated} {`
33			`catch "Foo x" errmsg`
34			`} {`
35			`$result == 1`
36			`}`
37
38			`test {Create another object} {`
39			`Foo xx`
40			`} {`
41			`$result == "xx"`
42			`}`
43
44			`test {Create an object with an automatic name} {`
45			`Foo #auto`
46			`} {`
47			`[string match foo* $result]`
48			`}`
49
50			`test {Get list of objects in a class} {`
51			`itcl_info objects -class Foo`
52			`} {`
53			`[llength $result] == 3`
54			`}`
55
56			`# ----------------------------------------------------------------------`
57			`# PUBLIC VARIABLES`
58			`# ----------------------------------------------------------------------`
59			`test {Info: all public variables} {`
60			`x info public`
61			`} {`
62			`[test_cmp_lists $result {Foo::blit Foo::blat Foo::blot}]`
63			`}`
64
65			`test {Info: public variable initial value} {`
66			`x info public blit -init`
67			`} {`
68			`$result == ""`
69			`}`
70
71			`test {Info: public variable initial value (undefined)} {`
72			`x info public blit -value`
73			`} {`
74			`$result == ""`
75			`}`
76
77			`test {Info: public variable initial value} {`
78			`x info public blat -init`
79			`} {`
80			`$result == 0`
81			`}`
82
83			`test {Info: public variable current value} {`
84			`x info public blot -value`
85			`} {`
86			`$result == 1`
87			`}`
88
89			`test {Info: public variable config statement} {`
90			`x info public blit -config`
91			`} {`
92			`$result == ""`
93			`}`
94
95			`test {Info: public variable config statement} {`
96			`x info public blot -config`
97			`} {`
98			`$result == {global WATCH; set WATCH "blot=$blot"}`
99			`}`
100
101			`# ----------------------------------------------------------------------`
102			`# CONFIG-ING PUBLIC VARIABLES`
103			`# ----------------------------------------------------------------------`
104			`test {Setting public variables via "config"} {`
105			`x config -blit 27 -blat xyz`
106			`} {`
107			`$result == "Foo::blit Foo::blat"`
108			`}`
109
110			`test {Info: public variable init/current value} {`
111			`x info public blit -init -value`
112			`} {`
113			`$result == {{} 27}`
114			`}`
115
116			`test {Info: public variable init/current value} {`
117			`x info public blat -init -value`
118			`} {`
119			`$result == {0 xyz}`
120			`}`
121
122			`test {"config" is ordinary arg if it is not last arg} {`
123			`x configx -blit pdq`
124			`} {`
125			`$result == {-blit\|pdq}`
126			`}`
127
128			`test {Public variables with "config" code} {`
129			`set WATCH ""`
130			`concat [x config -blot abc] / $WATCH`
131			`} {`
132			`$result == "Foo::blot / blot=abc"`
133			`}`
134
135			`test {Make sure object data is local to objects} {`
136			`x config -blit abc`
137			`xx config -blit xyz`
138			`concat [x info public blit -value] / [xx info public blit -value]`
139			`} {`
140			`$result == "abc / xyz"`
141			`}`
142
143			`# ----------------------------------------------------------------------`
144			`# PROTECTED VARIABLES`
145			`# ----------------------------------------------------------------------`
146			`test {Info: all protected variables} {`
147			`x info protected`
148			`} {`
149			`[test_cmp_lists $result {Foo::_blit Foo::_blat Foo::this}]`
150			`}`
151
152			`test {Info: protected "this" variable} {`
153			`x info protected this -value`
154			`} {`
155			`$result == "::x"`
156			`}`
157
158			`test {Info: protected "this" variable} {`
159			`xx info protected this -value`
160			`} {`
161			`$result == "::xx"`
162			`}`
163
164			`test {Info: protected variable initial value} {`
165			`x info protected _blit -init`
166			`} {`
167			`$result == ""`
168			`}`
169
170			`test {Info: protected variable access/value} {`
171			`x do {set _blit rst}`
172			`} {`
173			`$result == "Foo says 'rst'" &&`
174			`[x info protected _blit -value] == "rst"`
175			`}`
176
177			`# ----------------------------------------------------------------------`
178			`# COMMON VARIABLES`
179			`# ----------------------------------------------------------------------`
180			`test {Info: all protected variables} {`
181			`x info common`
182			`} {`
183			`[test_cmp_lists $result {Foo::foos Foo::nfoo}]`
184			`}`
185
186			`test {Info: common variable initial value} {`
187			`x info common foos -init`
188			`} {`
189			`$result == ""`
190			`}`
191
192			`test {Info: common variable initial value} {`
193			`x info common nfoo -init`
194			`} {`
195			`$result == 0`
196			`}`
197
198			`test {Info: common variable access/value} {`
199			`x do {set nfoo 999}`
200			`x info common nfoo -value`
201			`} {`
202			`$result == 999`
203			`}`
204
205			`test {Make sure common data is really common} {`
206			`x do {set nfoo 0}`
207			`x info common nfoo -value`
208			`} {`
209			`$result == [xx info common nfoo -value]`
210			`}`
211
212			`test {Access common data in proc} {`
213			`x do {set nfoo 10}`
214			`Foo :: nfoos`
215			`} {`
216			`$result == 10`
217			`}`
218
219			`test {Common variables can be initialized within class definition} {`
220			`x do {if {[info exists foos(_ignore_)]} {set foos(_ignore_)}}`
221			`} {`
222			`$result == "Foo says 'foos-is-now-an-array'"`
223			`}`
224
225			`test {Arrays as common data} {`
226			`Foo :: foos`
227			`} {`
228			`[test_cmp_lists $result [itcl_info objects -class Foo]]`
229			`}`
230
231			`# ----------------------------------------------------------------------`
232			`# METHODS`
233			`# ----------------------------------------------------------------------`
234			`test {Info: all methods} {`
235			`x info method`
236			`} {`
237			`[test_cmp_lists $result {`
238			`Foo::constructor Foo::destructor`
239			`Foo::nothing Foo::do Foo::xecho`
240			`Foo::config Foo::xconfig Foo::configx`
241			`Foo::testMethodArgs`
242			`Foo::configure Foo::delete Foo::cget Foo::isa`
243			`}]`
244			`}`
245
246			`test {Info: method args} {`
247			`x info method nothing -args`
248			`} {`
249			`$result == ""`
250			`}`
251
252			`test {Info: method args} {`
253			`x info method xconfig -args`
254			`} {`
255			`$result == "x config"`
256			`}`
257
258			`test {Info: method body} {`
259			`x info method nothing -body`
260			`} {`
261			`$result == ""`
262			`}`
263
264			`test {Info: method body} {`
265			`x info method xconfig -body`
266			`} {`
267			`$result == {`
268			`return "$x\|$config"`
269			`}`
270			`}`
271
272			`# ----------------------------------------------------------------------`
273			`# PROCS`
274			`# ----------------------------------------------------------------------`
275			`test {Info: all procs} {`
276			`x info proc`
277			`} {`
278			`[test_cmp_lists $result {`
279			`Foo::echo Foo::foos Foo::nfoos Foo::testProcArgs`
280			`}]`
281			`}`
282
283			`test {Info: proc args} {`
284			`x info proc nfoos -args`
285			`} {`
286			`$result == ""`
287			`}`
288
289			`test {Info: proc args} {`
290			`x info proc foos -args`
291			`} {`
292			`$result == "{pattern *}"`
293			`}`
294
295			`test {Info: proc body} {`
296			`x info proc nfoos -body`
297			`} {`
298			`$result == {`
299			`return $nfoo`
300			`}`
301			`}`
302
303			`test {Info: proc body} {`
304			`x info body nfoos`
305			`} {`
306			`$result == {`
307			`return $nfoo`
308			`}`
309			`}`
310
311			`# ----------------------------------------------------------------------`
312			`# ARGUMENT LISTS`
313			`# ----------------------------------------------------------------------`
314			`test {Default arguments can get assigned a proper value} {`
315			`Foo :: foos x*`
316			`} {`
317			`[test_cmp_lists $result {x xx}]`
318			`}`
319
320			`test {Default value for "config" argument} {`
321			`x config`
322			`} {`
323			`$result == "Foo::blit Foo::blat" &&`
324			`[x info public blit -value] == "auto" &&`
325			`[x info public blat -value] == "matic"`
326			`}`
327
328			`test {"args" formal argument absorbs extra arguments} {`
329			`Foo :: echo abc 1 2 3`
330			`} {`
331			`$result == "abc \| 3: 1 2 3"`
332			`}`
333
334			`test {"args" formal argument absorbs extra arguments} {`
335			`Foo :: echo def`
336			`} {`
337			`$result == "def \| 0: "`
338			`}`
339
340			`test {"args" formal argument absorbs extra arguments} {`
341			`x xecho abc 1 2 3`
342			`} {`
343			`$result == "abc \| 3: 1 2 3"`
344			`}`
345
346			`test {"args" formal argument absorbs extra arguments} {`
347			`x xecho def`
348			`} {`
349			`$result == "def \| 0: "`
350			`}`
351
352			`test {Extra args cause an error} {`
353			`catch "x configx arg arg error"`
354			`} {`
355			`$result != 0`
356			`}`
357
358			`test {Extra args cause an error} {`
359			`catch "x nothing error"`
360			`} {`
361			`$result != 0`
362			`}`
363
364			`test {Formal arguments don't clobber public/protected variables} {`
365			`x do {`
366			`set blit okay`
367			`set _blit no-problem`
368			`}`
369			`x testMethodArgs yuck puke etc.`
370			`} {`
371			`$result == "yuck, puke, and 1 other args" &&`
372			`[x info public blit -value] == "okay" &&`
373			`[x info protected _blit -value] == "no-problem"`
374			`}`
375
376			`test {Formal arguments don't clobber common variables} {`
377			`Foo :: testProcArgs yuck etc.`
378			`} {`
379			`$result == "yuck, and 1 other args" &&`
380			`[x info common nfoo -value] != "yuck"`
381			`}`
382
383			`# ----------------------------------------------------------------------`
384			`# DELETING OBJECTS`
385			`# ----------------------------------------------------------------------`
386			`test {Delete an object} {`
387			`x delete`
388			`} {`
389			`$result == ""`
390			`}`
391
392			`test {Delete an object} {`
393			`xx delete`
394			`} {`
395			`$result == ""`
396			`}`
397
398			`test {Destructor is properly invoked} {`
399			`Foo :: foos`
400			`} {`
401			`[test_cmp_lists $result [itcl_info objects -class Foo]]`
402			`}`
403
404			`test {Object names are removed as commands} {`
405			`expr {[info commands x] == "" && [info commands xx] == ""}`
406			`} {`
407			`$result == 1`
408			`}`