Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/tests/var.test @ 47

Last change on this file since 47 was 25, checked in by landauf, 16 years ago

added tcl to libs

File size: 23.9 KB
Line 
1# This file contains tests for the tclVar.c source file. Tests appear in
2# the same order as the C code that they test. The set of tests is
3# currently incomplete since it currently includes only new tests for
4# code changed for the addition of Tcl namespaces. Other variable-
5# related tests appear in several other test files including
6# namespace.test, set.test, trace.test, and upvar.test.
7#
8# Sourcing this file into Tcl runs the tests and generates output for
9# errors. No output means no errors were found.
10#
11# Copyright (c) 1997 Sun Microsystems, Inc.
12# Copyright (c) 1998-1999 by Scriptics Corporation.
13#
14# See the file "license.terms" for information on usage and redistribution
15# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16#
17# RCS: @(#) $Id: var.test,v 1.31 2008/03/11 17:23:56 msofer Exp $
18#
19
20if {[lsearch [namespace children] ::tcltest] == -1} {
21    package require tcltest 2.2
22    namespace import -force ::tcltest::*
23}
24
25testConstraint testupvar [llength [info commands testupvar]]
26testConstraint testgetvarfullname [llength [info commands testgetvarfullname]]
27testConstraint testsetnoerr [llength [info commands testsetnoerr]]
28
29catch {rename p ""}
30catch {namespace delete test_ns_var}
31catch {unset xx}
32catch {unset x}
33catch {unset y}
34catch {unset i}
35catch {unset a}
36catch {unset arr}
37
38test var-1.1 {TclLookupVar, Array handling} {
39    catch {unset a}
40    set x "incr"  ;# force no compilation and runtime call to Tcl_IncrCmd
41    set i 10
42    set arr(foo) 37
43    list [$x i] $i [$x arr(foo)] $arr(foo)
44} {11 11 38 38}
45test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} {
46    set x "global value"
47    namespace eval test_ns_var {
48        variable x "namespace value"
49        proc p {} {
50            global x  ;# specifies TCL_GLOBAL_ONLY to get global x
51            return $x
52        }
53    }
54    test_ns_var::p
55} {global value}
56test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} {
57    namespace eval test_ns_var {
58        proc q {} {
59            variable x  ;# specifies TCL_NAMESPACE_ONLY to get namespace x
60            return $x
61        }
62    }
63    test_ns_var::q
64} {namespace value}
65test var-1.4 {TclLookupVar, no active call frame implies global namespace var} {
66    set x
67} {global value}
68test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} {
69    namespace eval test_ns_var {set x}
70} {namespace value}
71test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} {
72    namespace eval test_ns_var {set ::x}
73} {global value}
74test var-1.7 {TclLookupVar, error finding namespace var} {
75    list [catch {set a:::b} msg] $msg
76} {1 {can't read "a:::b": no such variable}}
77test var-1.8 {TclLookupVar, error finding namespace var} {
78    list [catch {set ::foobarfoo} msg] $msg
79} {1 {can't read "::foobarfoo": no such variable}}
80test var-1.9 {TclLookupVar, create new namespace var} {
81    namespace eval test_ns_var {
82        set v hello
83    }
84} {hello}
85test var-1.10 {TclLookupVar, create new namespace var} {
86    catch {unset y}
87    namespace eval test_ns_var {
88        set ::y 789
89    }
90    set y
91} {789}
92test var-1.11 {TclLookupVar, error creating new namespace var} {
93    namespace eval test_ns_var {
94        list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg
95    }
96} {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}}
97test var-1.12 {TclLookupVar, error creating new namespace var} {
98    namespace eval test_ns_var {
99        list [catch {set ::test_ns_var::foo:: 1997} msg] $msg
100    }
101} {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}}
102test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} {
103    catch {unset aNeWnAmEiNnS}
104    namespace eval test_ns_var {
105        namespace eval test_ns_var2::test_ns_var3 {
106            set aNeWnAmEiNnS 77777
107        }
108        # namespace which builds a name by traversing nsPtr chain to ::
109        namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS
110    }
111} {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS}
112test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} {
113    namespace eval test_ns_var {
114        set : 123
115        set v: 456
116        set x:y: 789
117        list [set :] [set v:] [set x:y:] \
118             ${:} ${v:} ${x:y:} \
119             [expr {[lsearch [info vars] :] != -1}] \
120             [expr {[lsearch [info vars] v:] != -1}] \
121             [expr {[lsearch [info vars] x:y:] != -1}]
122    }
123} {123 456 789 123 456 789 1 1 1}
124test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} {
125    namespace eval test_ns_var {
126        variable foo 2
127    }
128    proc p {} {
129        variable ::test_ns_var::foo
130        lappend result [catch {set foo} msg] $msg
131        namespace delete ::test_ns_var
132        lappend result [catch {set foo 3} msg] $msg
133        lappend result [catch {set foo(3) 3} msg] $msg
134    }
135    p
136} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}}
137test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} {
138    namespace eval test_ns_var {
139        variable result
140        namespace eval subns {
141            variable foo 2
142        }
143        upvar 0 subns::foo foo
144        lappend result [catch {set foo} msg] $msg
145        namespace delete subns
146        lappend result [catch {set foo 3} msg] $msg
147        lappend result [catch {set foo(3) 3} msg] $msg
148        namespace delete [namespace current]
149        set result
150    }
151} {0 2 1 {can't set "foo": upvar refers to variable in deleted namespace} 1 {can't set "foo(3)": upvar refers to variable in deleted namespace}}
152test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} {
153    namespace eval test_ns_var {
154        variable result
155        proc p {} {
156            array set x {1 2 3 4}
157            upvar 0 x(1) foo
158            lappend result [catch {set foo} msg] $msg
159            unset x
160            lappend result [catch {set foo 3} msg] $msg
161        }
162        set result [p]
163        namespace delete [namespace current]
164        set result
165    }
166} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
167test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} {
168    namespace eval test_ns_var {
169        variable result {}
170        variable x
171        array set x {1 2 3 4}
172        upvar 0 x(1) foo
173        lappend result [catch {set foo} msg] $msg
174        unset x
175        lappend result [catch {set foo 3} msg] $msg
176        namespace delete [namespace current]
177        set result
178    }
179} {0 2 1 {can't set "foo": upvar refers to element in deleted array}}
180test var-1.19 {TclLookupVar, right error message when parsing variable name} {
181    list [catch {[format set] thisvar(doesntexist)} msg] $msg
182} {1 {can't read "thisvar(doesntexist)": no such variable}}
183
184test var-2.1 {Tcl_LappendObjCmd, create var if new} {
185    catch {unset x}
186    lappend x 1 2
187} {1 2}
188
189test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} {
190    catch {unset x}
191    set x 1997
192    proc p {} {
193        global x  ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x
194        return $x
195    }
196    p
197} {1997}
198test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} {
199    namespace eval test_ns_var {
200        catch {unset v}
201        variable v 1998
202        proc p {} {
203            variable v  ;# TCL_NAMESPACE_ONLY specified for other var x
204            return $v
205        }
206        p
207    }
208} {1998}
209test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} testupvar {
210    catch {unset a}
211    set a 123321
212    proc p {} {
213        # create global xx linked to global a
214        testupvar 1 a {} xx global
215    }
216    list [p] $xx [set xx 789] $a
217} {{} 123321 789 789}
218test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} testupvar {
219    catch {unset a}
220    set a 456
221    namespace eval test_ns_var {
222        catch {unset ::test_ns_var::vv}
223        proc p {} {
224            # create namespace var vv linked to global a
225            testupvar 1 a {} vv namespace
226        }
227        p
228    }
229    list $test_ns_var::vv [set test_ns_var::vv 123] $a
230} {456 123 123}
231test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} {
232    catch {unset aaaaa}
233    catch {unset xxxxx}
234    set aaaaa 77777
235    upvar #0 aaaaa xxxxx
236    list [set xxxxx] [set aaaaa]
237} {77777 77777}
238test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} {
239    catch {unset a}
240    set a 121212
241    namespace eval test_ns_var {
242        upvar ::a vvv
243        set vvv
244    }
245} {121212}
246test var-3.7 {MakeUpvar, my var has ::s} {
247    catch {unset a}
248    set a 789789
249    upvar #0 a test_ns_var::lnk
250    namespace eval test_ns_var {
251        set lnk
252    }
253} {789789}
254test var-3.8 {MakeUpvar, my var already exists in global ns} {
255    catch {unset aaaaa}
256    catch {unset xxxxx}
257    set aaaaa 456654
258    set xxxxx hello
259    upvar #0 aaaaa xxxxx
260    set xxxxx
261} {hello}
262test var-3.9 {MakeUpvar, my var has invalid ns name} {
263    catch {unset aaaaa}
264    set aaaaa 789789
265    list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg
266} {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}}
267test var-3.10 {MakeUpvar, } {
268    namespace eval {} {
269        set bar 0
270        namespace eval foo upvar bar bar
271        set foo::bar 1
272        catch {list $bar $foo::bar} msg
273        unset ::aaaaa
274        set msg
275    }
276} {1 1}
277test var-3.11 {MakeUpvar, my var looks like array elem} -body {
278    catch {unset aaaaa}
279    set aaaaa 789789
280    upvar #0 aaaaa foo(bar)
281} -returnCodes 1 -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element}
282
283test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname {
284    catch {unset a}
285    set a 123
286    testgetvarfullname a global
287} ::a
288test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname {
289    namespace eval test_ns_var {
290        variable george
291        testgetvarfullname george namespace
292    }
293} ::test_ns_var::george
294test var-4.3 {Tcl_GetVariableName, variable can't be array element} testgetvarfullname {
295    catch {unset a}
296    set a(1) foo
297    list [catch {testgetvarfullname a(1) global} msg] $msg
298} {1 {unknown variable "a(1)"}}
299
300test var-5.1 {Tcl_GetVariableFullName, global variable} {
301    catch {unset a}
302    set a bar
303    namespace which -variable a
304} {::a}
305test var-5.2 {Tcl_GetVariableFullName, namespace variable} {
306    namespace eval test_ns_var {
307        variable martha
308        namespace which -variable martha
309    }
310} {::test_ns_var::martha}
311test var-5.3 {Tcl_GetVariableFullName, namespace variable} {
312    namespace which -variable test_ns_var::martha
313} {::test_ns_var::martha}
314
315test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
316    namespace eval test_ns_var {
317        variable boeing 777
318    }
319    proc p {} {
320        global ::test_ns_var::boeing
321        set boeing
322    }
323    p
324} {777}
325test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {
326    namespace eval test_ns_var {
327        namespace eval test_ns_nested {
328            variable java java
329        }
330        proc p {} {
331            global ::test_ns_var::test_ns_nested::java
332            set java
333        }
334    }
335    test_ns_var::p
336} {java}
337test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} {
338    set ::test_ns_var::test_ns_nested:: 24
339    proc p {} {
340        global ::test_ns_var::test_ns_nested::
341        set {}
342    }
343    p
344} {24}
345test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} {
346    # Test for Tcl Bug 480176
347    set :v broken
348    proc p {} {
349        global :v
350        set :v fixed
351    }
352    p
353    set :v
354} {fixed}
355
356test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} {
357    catch {namespace delete test_ns_var}
358    namespace eval test_ns_var {
359        variable one 1
360    }
361    list [info vars test_ns_var::*] [set test_ns_var::one]
362} {::test_ns_var::one 1}
363test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} {
364    set two 2222222
365    namespace eval test_ns_var {
366        variable two
367    }
368    list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg
369} {0 1 {can't read "test_ns_var::two": no such variable}}
370test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} {
371    namespace eval test_ns_var {
372        variable two 2
373    }
374    list [lsort [info vars test_ns_var::*]] \
375         [namespace eval test_ns_var {set two}]
376} [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2]
377test var-7.4 {Tcl_VariableObjCmd, list of vars} {
378    namespace eval test_ns_var {
379        variable three 3 four 4
380    }
381    list [lsort [info vars test_ns_var::*]] \
382         [namespace eval test_ns_var {expr $three+$four}]
383} [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7]
384test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} {
385    catch {unset a}
386    catch {unset five}
387    catch {unset six}
388    set a ""
389    set five 555
390    set six  666
391    namespace eval test_ns_var {
392        variable five 5 six
393        lappend a $five
394    }
395    lappend a $test_ns_var::five \
396        [set test_ns_var::six 6] [set test_ns_var::six] $six
397    catch {unset five}
398    catch {unset six}
399    set a
400} {5 5 6 6 666}
401catch {unset newvar}
402test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} {
403    namespace eval test_ns_var {
404        variable ::newvar cheers!
405    }
406    set newvar
407} {cheers!}
408catch {unset newvar}
409test var-7.7 {Tcl_VariableObjCmd, bad var name} {
410    namespace eval test_ns_var {
411        list [catch {variable sev:::en 7} msg] $msg
412    }
413} {1 {can't define "sev:::en": parent namespace doesn't exist}}
414test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} {
415    set a ""
416    namespace eval test_ns_var {
417        variable eight 8
418        lappend a $eight
419        variable eight
420        lappend a $eight
421    }
422    set a
423} {8 8}
424test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} {
425    catch {namespace delete test_ns_var2}
426    set a ""
427    namespace eval test_ns_var2 {
428        variable x 123
429        variable y
430        variable z
431    }
432    lappend a [lsort [info vars test_ns_var2::*]]
433    lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \
434        [info exists test_ns_var2::z]
435    lappend a [list [catch {set test_ns_var2::y} msg] $msg]
436    lappend a [lsort [info vars test_ns_var2::*]]
437    lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
438    lappend a [set test_ns_var2::y hello]
439    lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
440    lappend a [list [catch {unset test_ns_var2::y} msg] $msg]
441    lappend a [lsort [info vars test_ns_var2::*]]
442    lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]
443    lappend a [list [catch {unset test_ns_var2::z} msg] $msg]
444    lappend a [namespace delete test_ns_var2]
445    set a
446} [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\
447        {1 {can't read "test_ns_var2::y": no such variable}}\
448        [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\
449        hello 1 0\
450        {0 {}}\
451        [lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\
452        {1 {can't unset "test_ns_var2::z": no such variable}}\
453        {}]
454test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
455    namespace eval test_ns_var {
456        proc p {} {
457            variable eight
458            list [set eight] [info vars]
459        }
460        p
461    }
462} {8 eight}
463test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
464    proc p {} {   ;# note this proc is at global :: scope
465        variable test_ns_var::eight
466        list [set eight] [info vars]
467    }
468    p
469} {8 eight}
470test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {
471    namespace eval test_ns_var {
472        variable {} {My name is empty}
473    }
474    proc p {} {   ;# note this proc is at global :: scope
475        variable test_ns_var::
476        list [set {}] [info vars]
477    }
478    p
479} {{My name is empty} {{}}}
480test var-7.13 {Tcl_VariableObjCmd, variable named ":"} {
481    namespace eval test_ns_var {
482        variable : {My name is ":"}
483        proc p {} {
484            variable :
485            list [set :] [info vars]
486        }
487        p
488    }
489} {{My name is ":"} :}
490test var-7.14 {Tcl_VariableObjCmd, array element parameter} {
491    catch {namespace eval test_ns_var { variable arrayvar(1) }} res
492    set res
493} "can't define \"arrayvar(1)\": name refers to an element in an array"
494test var-7.15 {Tcl_VariableObjCmd, array element parameter} {
495    catch {
496        namespace eval test_ns_var {
497            variable arrayvar
498            set arrayvar(1) x
499            variable arrayvar(1) y
500        }   
501    } res
502    set res
503} "can't define \"arrayvar(1)\": name refers to an element in an array"
504test var-7.16 {Tcl_VariableObjCmd, no args} {
505    list [catch {variable} msg] $msg
506} {1 {wrong # args: should be "variable ?name value...? name ?value?"}}
507test var-7.17 {Tcl_VariableObjCmd, no args} {
508    namespace eval test_ns_var {
509        list [catch {variable} msg] $msg
510    }
511} {1 {wrong # args: should be "variable ?name value...? name ?value?"}}
512
513test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} {
514    catch {namespace delete test_ns_var}
515    catch {unset a}
516    namespace eval test_ns_var {
517        variable v 123
518        variable info ""
519
520        proc traceUnset {name1 name2 op} {
521            variable info
522            set info [concat $info [list $name1 $name2 $op]]
523        }
524
525        trace var v u [namespace code traceUnset]
526    }
527    list [unset test_ns_var::v] $test_ns_var::info
528} {{} {test_ns_var::v {} u}}
529
530test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} {
531    catch {namespace delete test_ns_var}
532    catch {unset a}
533    set info ""
534    namespace eval test_ns_var {
535        variable v 123 1
536        trace var v u ::traceUnset
537    }
538
539    proc traceUnset {name1 name2 op} {
540        set ::info [concat $::info [list $name1 $name2 $op]]
541    }
542
543    list [namespace delete test_ns_var] $::info
544} {{} {::test_ns_var::v {} u}}
545
546test var-9.1 {behaviour of TclGet/SetVar simple get/set} testsetnoerr {
547    catch {unset u}; catch {unset v}
548    list \
549       [set u a; testsetnoerr u] \
550       [testsetnoerr v b] \
551       [testseterr u] \
552       [unset v; testseterr v b]
553} [list {before get a} {before set b} {before get a} {before set b}]
554test var-9.2 {behaviour of TclGet/SetVar namespace get/set} testsetnoerr {
555    catch {namespace delete ns}
556    namespace eval ns {variable u a; variable v}
557    list \
558       [testsetnoerr ns::u] \
559       [testsetnoerr ns::v b] \
560       [testseterr ns::u] \
561       [unset ns::v; testseterr ns::v b]
562} [list {before get a} {before set b} {before get a} {before set b}]
563test var-9.3 {behaviour of TclGetVar no variable} testsetnoerr {
564    catch {unset u}
565    list \
566       [catch {testsetnoerr u} res] $res \
567       [catch {testseterr u} res] $res
568} {1 {before get} 1 {can't read "u": no such variable}}
569test var-9.4 {behaviour of TclGetVar no namespace variable} testsetnoerr {
570    catch {namespace delete ns}
571    namespace eval ns {}
572    list \
573       [catch {testsetnoerr ns::w} res] $res \
574       [catch {testseterr ns::w} res] $res
575} {1 {before get} 1 {can't read "ns::w": no such variable}}
576test var-9.5 {behaviour of TclGetVar no namespace} testsetnoerr {
577    catch {namespace delete ns}
578    list \
579       [catch {testsetnoerr ns::u} res] $res \
580       [catch {testseterr ns::v} res] $res
581} {1 {before get} 1 {can't read "ns::v": no such variable}}
582test var-9.6 {behaviour of TclSetVar no namespace} testsetnoerr {
583    catch {namespace delete ns}
584    list \
585       [catch {testsetnoerr ns::v 1} res] $res \
586       [catch {testseterr ns::v 1} res] $res
587} {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}}
588test var-9.7 {behaviour of TclGetVar array variable} testsetnoerr {
589    catch {unset arr}
590    set arr(1) 1;
591    list \
592       [catch {testsetnoerr arr} res] $res \
593       [catch {testseterr arr} res] $res
594} {1 {before get} 1 {can't read "arr": variable is array}}
595test var-9.8 {behaviour of TclSetVar array variable} testsetnoerr {
596    catch {unset arr}
597    set arr(1) 1
598    list \
599       [catch {testsetnoerr arr 2} res] $res \
600       [catch {testseterr arr 2} res] $res
601} {1 {before set} 1 {can't set "arr": variable is array}}
602test var-9.9 {behaviour of TclGetVar read trace success} testsetnoerr {
603    proc resetvar {val name elem op} {upvar 1 $name v; set v $val}
604    catch {unset u}; catch {unset v}
605    set u 10
606    trace var u r [list resetvar 1]
607    trace var v r [list resetvar 2]
608    list \
609       [testsetnoerr u] \
610       [testseterr v]
611} {{before get 1} {before get 2}}
612test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr {
613    proc writeonly args {error "write-only"}
614    set v 456
615    trace var v r writeonly
616    list \
617       [catch {testsetnoerr v} msg] $msg \
618       [catch {testseterr v} msg] $msg
619} {1 {before get} 1 {can't read "v": write-only}}
620test var-9.11 {behaviour of TclSetVar write trace success} testsetnoerr {
621    proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]}
622    catch {unset u}; catch {unset v}
623    set v 1
624    trace var v w doubleval
625    trace var u w doubleval
626    list \
627       [testsetnoerr u 2] \
628       [testseterr v 3]
629} {{before set 4} {before set 6}}
630test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr {
631    proc readonly args {error "read-only"}
632    set v 456
633    trace var v w readonly
634    list \
635       [catch {testsetnoerr v 2} msg] $msg $v \
636       [catch {testseterr v 3} msg] $msg $v
637} {1 {before set} 2 1 {can't set "v": read-only} 3}
638
639test var-10.1 {can't nest arrays with array set} {
640   catch {unset arr}
641   list [catch {array set arr(x) {a 1 b 2}} res] $res
642} {1 {can't set "arr(x)": variable isn't array}}
643test var-10.2 {can't nest arrays with array set} {
644   catch {unset arr}
645   list [catch {array set arr(x) {}} res] $res
646} {1 {can't set "arr(x)": variable isn't array}}
647
648test var-11.1 {array unset} {
649    catch {unset a}
650    array set a { 1,1 a 1,2 b 2,1 c 2,3 d }
651    array unset a 1,*
652    lsort -dict [array names a]
653} {2,1 2,3}
654test var-11.2 {array unset} {
655    catch {unset a}
656    array set a { 1,1 a 1,2 b }
657    array unset a
658    array exists a
659} 0
660test var-11.3 {array unset errors} {
661    catch {unset a}
662    array set a { 1,1 a 1,2 b }
663    list [catch {array unset a pattern too} msg] $msg
664} {1 {wrong # args: should be "array unset arrayName ?pattern?"}}
665
666test var-12.1 {TclFindCompiledLocals, {} array name} {
667    namespace eval n {
668        proc p {} {
669            variable {}
670            set (0) 0
671            set (1) 1
672            set n 2
673            set ($n) 2
674            set ($n,foo) 2
675        }
676        p
677        lsort -dictionary [array names {}]
678    }
679} {0 1 2 2,foo}
680
681test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} {
682    catch {unset t}
683    proc foo {var ind op} {
684        global t
685        set foo bar
686    }
687    namespace eval :: {
688        set t(1) 1
689        trace variable t(1) u foo
690        unset t
691    }
692    set x "If you see this, it worked"
693} "If you see this, it worked"
694
695test var-14.1 {array names syntax} -body {
696    array names foo bar baz snafu
697} -returnCodes 1 -match glob -result *
698
699test var-14.2 {array names -glob} -body {
700    array names tcl_platform -glob os
701} -returnCodes 0 -match exact -result os
702
703test var-15.1 {segfault in [unset], [Bug 735335]} {
704    proc A { name } {
705        upvar $name var
706        set var $name
707    }
708    #
709    # Note that the variable name has to be
710    # unused previously for the segfault to
711    # be triggered.
712    #
713    namespace eval test A useSomeUnlikelyNameHere
714    namespace eval test unset useSomeUnlikelyNameHere
715} {}
716
717
718test var-16.1 {CallVarTraces: save/restore interp error state} {
719    trace add variable ::errorCode write { ;#}
720    catch {error foo bar baz}
721    trace remove variable ::errorCode write { ;#}
722    set ::errorInfo
723} bar
724
725test var-17.1 {TclArraySet [Bug 1669489]} -setup {
726    unset -nocomplain ::a
727} -body {
728    namespace eval :: {
729        set elements {1 2 3 4}
730        trace add variable a write {string length $elements ;#}
731        array set a $elements
732    }
733} -cleanup {
734    unset -nocomplain ::a ::elements
735} -result {}
736
737catch {namespace delete ns}
738catch {unset arr}
739catch {unset v}
740
741catch {rename p ""}
742catch {namespace delete test_ns_var}
743catch {namespace delete test_ns_var2}
744catch {unset xx}
745catch {unset x}
746catch {unset y}
747catch {unset i}
748catch {unset a}
749catch {unset xxxxx}
750catch {unset aaaaa}
751
752# cleanup
753::tcltest::cleanupTests
754return
Note: See TracBrowser for help on using the repository browser.