Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/var.test@260cb5ec6c19

     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.20.2.4 2007/03/13 15:59:53 dgp Exp $

    18 #

    20 if {[lsearch [namespace children] ::tcltest] == -1} {

    21     package require tcltest 2.2

    22     namespace import -force ::tcltest::*

    23 }

    25 catch {rename p ""}

    26 catch {namespace delete test_ns_var}

    27 catch {unset xx}

    28 catch {unset x}

    29 catch {unset y}

    30 catch {unset i}

    31 catch {unset a}

    32 catch {unset arr}

    34 test var-1.1 {TclLookupVar, Array handling} {

    35     catch {unset a}

    36     set x "incr"  ;# force no compilation and runtime call to Tcl_IncrCmd

    37     set i 10

    38     set arr(foo) 37

    39     list [$x i] $i [$x arr(foo)] $arr(foo)

    40 } {11 11 38 38}

    41 test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} {

    42     set x "global value"

    43     namespace eval test_ns_var {

    44         variable x "namespace value"

    45         proc p {} {

    46             global x  ;# specifies TCL_GLOBAL_ONLY to get global x

    47             return $x

    48         }

    49     }

    50     test_ns_var::p

    51 } {global value}

    52 test var-1.3 {TclLookupVar, TCL_NAMESPACE_ONLY implies namespace var} {

    53     namespace eval test_ns_var {

    54         proc q {} {

    55             variable x  ;# specifies TCL_NAMESPACE_ONLY to get namespace x

    56             return $x

    57         }

    58     }

    59     test_ns_var::q

    60 } {namespace value}

    61 test var-1.4 {TclLookupVar, no active call frame implies global namespace var} {

    62     set x

    63 } {global value}

    64 test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies namespace var} {

    65     namespace eval test_ns_var {set x}

    66 } {namespace value}

    67 test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} {

    68     namespace eval test_ns_var {set ::x}

    69 } {global value}

    70 test var-1.7 {TclLookupVar, error finding namespace var} {

    71     list [catch {set a:::b} msg] $msg

    72 } {1 {can't read "a:::b": no such variable}}

    73 test var-1.8 {TclLookupVar, error finding namespace var} {

    74     list [catch {set ::foobarfoo} msg] $msg

    75 } {1 {can't read "::foobarfoo": no such variable}}

    76 test var-1.9 {TclLookupVar, create new namespace var} {

    77     namespace eval test_ns_var {

    78         set v hello

    79     }

    80 } {hello}

    81 test var-1.10 {TclLookupVar, create new namespace var} {

    82     catch {unset y}

    83     namespace eval test_ns_var {

    84         set ::y 789

    85     }

    86     set y

    87 } {789}

    88 test var-1.11 {TclLookupVar, error creating new namespace var} {

    89     namespace eval test_ns_var {

    90         list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg

    91     }

    92 } {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}}

    93 test var-1.12 {TclLookupVar, error creating new namespace var} {

    94     namespace eval test_ns_var {

    95         list [catch {set ::test_ns_var::foo:: 1997} msg] $msg

    96     }

    97 } {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}}

    98 test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} {

    99     catch {unset aNeWnAmEiNnS}

   100     namespace eval test_ns_var {

   101         namespace eval test_ns_var2::test_ns_var3 {

   102             set aNeWnAmEiNnS 77777

   103         }

   104         # namespace which builds a name by traversing nsPtr chain to ::

   105         namespace which -variable test_ns_var2::test_ns_var3::aNeWnAmEiNnS

   106     }

   107 } {::test_ns_var::test_ns_var2::test_ns_var3::aNeWnAmEiNnS}

   108 test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of var names} {

   109     namespace eval test_ns_var {

   110         set : 123

   111         set v: 456

   112         set x:y: 789

   113         list [set :] [set v:] [set x:y:] \

   114              ${:} ${v:} ${x:y:} \

   115              [expr {[lsearch [info vars] :] != -1}] \

   116              [expr {[lsearch [info vars] v:] != -1}] \

   117              [expr {[lsearch [info vars] x:y:] != -1}]

   118     }

   119 } {123 456 789 123 456 789 1 1 1}

   120 test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} {

   121     namespace eval test_ns_var {

   122 	variable foo 2

   123     }

   124     proc p {} {

   125 	variable ::test_ns_var::foo

   126 	lappend result [catch {set foo} msg] $msg

   127         namespace delete ::test_ns_var

   128 	lappend result [catch {set foo 3} msg] $msg

   129 	lappend result [catch {set foo(3) 3} msg] $msg

   130     }

   131     p

   132 } {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}}

   133 test var-1.16 {TclLookupVar, resurrect variable via upvar to deleted namespace: uncompiled code path} {

   134     namespace eval test_ns_var {

   135 	variable result

   136         namespace eval subns {

   137 	    variable foo 2

   138 	}

   139 	upvar 0 subns::foo foo

   140 	lappend result [catch {set foo} msg] $msg

   141         namespace delete subns

   142 	lappend result [catch {set foo 3} msg] $msg

   143 	lappend result [catch {set foo(3) 3} msg] $msg

   144         namespace delete [namespace current]

   145 	set result

   146     }

   147 } {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}}

   148 test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: compiled code path} {

   149     namespace eval test_ns_var {

   150 	variable result

   151 	proc p {} {

   152 	    array set x {1 2 3 4}

   153 	    upvar 0 x(1) foo

   154 	    lappend result [catch {set foo} msg] $msg

   155 	    unset x

   156 	    lappend result [catch {set foo 3} msg] $msg

   157 	}

   158 	set result [p]

   159         namespace delete [namespace current]

   160 	set result

   161     }

   162 } {0 2 1 {can't set "foo": upvar refers to element in deleted array}}

   163 test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} {

   164     namespace eval test_ns_var {

   165 	variable result {}

   166 	variable x

   167 	array set x {1 2 3 4}

   168 	upvar 0 x(1) foo

   169 	lappend result [catch {set foo} msg] $msg

   170 	unset x

   171 	lappend result [catch {set foo 3} msg] $msg

   172         namespace delete [namespace current]

   173 	set result

   174     }

   175 } {0 2 1 {can't set "foo": upvar refers to element in deleted array}}

   176 test var-1.19 {TclLookupVar, right error message when parsing variable name} {

   177     list [catch {[format set] thisvar(doesntexist)} msg] $msg

   178 } {1 {can't read "thisvar(doesntexist)": no such variable}}

   180 test var-2.1 {Tcl_LappendObjCmd, create var if new} {

   181     catch {unset x}

   182     lappend x 1 2

   183 } {1 2}

   185 test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} {

   186     catch {unset x}

   187     set x 1997

   188     proc p {} {

   189         global x  ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x

   190         return $x

   191     }

   192     p

   193 } {1997}

   194 test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} {

   195     namespace eval test_ns_var {

   196         catch {unset v}

   197         variable v 1998

   198         proc p {} {

   199             variable v  ;# TCL_NAMESPACE_ONLY specified for other var x

   200             return $v

   201         }

   202         p

   203     }

   204 } {1998}

   205 if {[info commands testupvar] != {}} {

   206     test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} {

   207         catch {unset a}

   208         set a 123321

   209         proc p {} {

   210             # create global xx linked to global a

   211 	    testupvar 1 a {} xx global

   212 	}

   213         list [p] $xx [set xx 789] $a

   214     } {{} 123321 789 789}

   215     test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} {

   216         catch {unset a}

   217         set a 456

   218         namespace eval test_ns_var {

   219             catch {unset ::test_ns_var::vv}

   220             proc p {} {

   221                 # create namespace var vv linked to global a

   222 	        testupvar 1 a {} vv namespace

   223 	    }

   224             p

   225         }

   226         list $test_ns_var::vv [set test_ns_var::vv 123] $a

   227     } {456 123 123}

   228 }

   229 test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} {

   230     catch {unset aaaaa}

   231     catch {unset xxxxx}

   232     set aaaaa 77777

   233     upvar #0 aaaaa xxxxx

   234     list [set xxxxx] [set aaaaa]

   235 } {77777 77777}

   236 test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} {

   237     catch {unset a}

   238     set a 121212

   239     namespace eval test_ns_var {

   240         upvar ::a vvv

   241         set vvv

   242     }

   243 } {121212}

   244 test var-3.7 {MakeUpvar, my var has ::s} {

   245     catch {unset a}

   246     set a 789789

   247     upvar #0 a test_ns_var::lnk

   248     namespace eval test_ns_var {

   249         set lnk

   250     }

   251 } {789789}

   252 test var-3.8 {MakeUpvar, my var already exists in global ns} {

   253     catch {unset aaaaa}

   254     catch {unset xxxxx}

   255     set aaaaa 456654

   256     set xxxxx hello

   257     upvar #0 aaaaa xxxxx

   258     set xxxxx

   259 } {hello}

   260 test var-3.9 {MakeUpvar, my var has invalid ns name} {

   261     catch {unset aaaaa}

   262     set aaaaa 789789

   263     list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg

   264 } {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}}

   265 test var-3.10 {MakeUpvar, } {

   266     namespace eval {} {

   267 	set bar 0

   268 	namespace eval foo upvar bar bar

   269 	set foo::bar 1

   270 	catch {list $bar $foo::bar} msg

   271 	unset ::aaaaa

   272 	set msg

   273     }

   274 } {1 1}

   276 if {[info commands testgetvarfullname] != {}} {

   277     test var-4.1 {Tcl_GetVariableName, global variable} {

   278         catch {unset a}

   279         set a 123

   280         testgetvarfullname a global

   281     } ::a

   282     test var-4.2 {Tcl_GetVariableName, namespace variable} {

   283         namespace eval test_ns_var {

   284             variable george

   285             testgetvarfullname george namespace

   286         }

   287     } ::test_ns_var::george

   288     test var-4.3 {Tcl_GetVariableName, variable can't be array element} {

   289         catch {unset a}

   290         set a(1) foo

   291         list [catch {testgetvarfullname a(1) global} msg] $msg

   292     } {1 {unknown variable "a(1)"}}

   293 }

   295 test var-5.1 {Tcl_GetVariableFullName, global variable} {

   296     catch {unset a}

   297     set a bar

   298     namespace which -variable a

   299 } {::a}

   300 test var-5.2 {Tcl_GetVariableFullName, namespace variable} {

   301     namespace eval test_ns_var {

   302         variable martha

   303         namespace which -variable martha

   304     }

   305 } {::test_ns_var::martha}

   306 test var-5.3 {Tcl_GetVariableFullName, namespace variable} {

   307     namespace which -variable test_ns_var::martha

   308 } {::test_ns_var::martha}

   310 test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {

   311     namespace eval test_ns_var {

   312         variable boeing 777

   313     }

   314     proc p {} {

   315         global ::test_ns_var::boeing

   316         set boeing

   317     }

   318     p

   319 } {777}

   320 test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} {

   321     namespace eval test_ns_var {

   322         namespace eval test_ns_nested {

   323             variable java java

   324         }

   325         proc p {} {

   326             global ::test_ns_var::test_ns_nested::java

   327             set java

   328         }

   329     }

   330     test_ns_var::p

   331 } {java}

   332 test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} {

   333     set ::test_ns_var::test_ns_nested:: 24

   334     proc p {} {

   335         global ::test_ns_var::test_ns_nested::

   336         set {}

   337     }

   338     p

   339 } {24}

   340 test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} {

   341     # Test for Tcl Bug 480176

   342     set :v broken

   343     proc p {} {

   344 	global :v

   345 	set :v fixed

   346     }

   347     p

   348     set :v

   349 } {fixed}

   351 test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} {

   352     catch {namespace delete test_ns_var}

   353     namespace eval test_ns_var {

   354         variable one 1

   355     }

   356     list [info vars test_ns_var::*] [set test_ns_var::one]

   357 } {::test_ns_var::one 1}

   358 test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} {

   359     set two 2222222

   360     namespace eval test_ns_var {

   361         variable two

   362     }

   363     list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg

   364 } {0 1 {can't read "test_ns_var::two": no such variable}}

   365 test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} {

   366     namespace eval test_ns_var {

   367         variable two 2

   368     }

   369     list [lsort [info vars test_ns_var::*]] \

   370          [namespace eval test_ns_var {set two}]

   371 } [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2]

   372 test var-7.4 {Tcl_VariableObjCmd, list of vars} {

   373     namespace eval test_ns_var {

   374         variable three 3 four 4

   375     }

   376     list [lsort [info vars test_ns_var::*]] \

   377          [namespace eval test_ns_var {expr $three+$four}]

   378 } [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7]

   379 test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} {

   380     catch {unset a}

   381     catch {unset five}

   382     catch {unset six}

   383     set a ""

   384     set five 555

   385     set six  666

   386     namespace eval test_ns_var {

   387         variable five 5 six

   388         lappend a $five

   389     }

   390     lappend a $test_ns_var::five \

   391         [set test_ns_var::six 6] [set test_ns_var::six] $six

   392     catch {unset five}

   393     catch {unset six}

   394     set a

   395 } {5 5 6 6 666}

   396 catch {unset newvar}

   397 test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} {

   398     namespace eval test_ns_var {

   399         variable ::newvar cheers!

   400     }

   401     set newvar

   402 } {cheers!}

   403 catch {unset newvar}

   404 test var-7.7 {Tcl_VariableObjCmd, bad var name} {

   405     namespace eval test_ns_var {

   406         list [catch {variable sev:::en 7} msg] $msg

   407     }

   408 } {1 {can't define "sev:::en": parent namespace doesn't exist}}

   409 test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} {

   410     set a ""

   411     namespace eval test_ns_var {

   412         variable eight 8

   413         lappend a $eight

   414         variable eight

   415         lappend a $eight

   416     }

   417     set a

   418 } {8 8}

   419 test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} {

   420     catch {namespace delete test_ns_var2}

   421     set a ""

   422     namespace eval test_ns_var2 {

   423         variable x 123

   424         variable y

   425         variable z

   426     }

   427     lappend a [lsort [info vars test_ns_var2::*]]

   428     lappend a [info exists test_ns_var2::x] [info exists test_ns_var2::y] \

   429         [info exists test_ns_var2::z]

   430     lappend a [list [catch {set test_ns_var2::y} msg] $msg]

   431     lappend a [lsort [info vars test_ns_var2::*]]

   432     lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]

   433     lappend a [set test_ns_var2::y hello]

   434     lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z]

   435     lappend a [list [catch {unset 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 [list [catch {unset test_ns_var2::z} msg] $msg]

   439     lappend a [namespace delete test_ns_var2]

   440     set a

   441 } [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\

   442 	{1 {can't read "test_ns_var2::y": no such variable}}\

   443 	[lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\

   444 	hello 1 0\

   445 	{0 {}}\

   446 	[lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\

   447 	{1 {can't unset "test_ns_var2::z": no such variable}}\

   448 	{}]

   449 test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {

   450     namespace eval test_ns_var {

   451         proc p {} {

   452             variable eight

   453             list [set eight] [info vars]

   454         }

   455         p

   456     }

   457 } {8 eight}

   458 test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {

   459     proc p {} {   ;# note this proc is at global :: scope

   460         variable test_ns_var::eight

   461         list [set eight] [info vars]

   462     }

   463     p

   464 } {8 eight}

   465 test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} {

   466     namespace eval test_ns_var {

   467         variable {} {My name is empty}

   468     }

   469     proc p {} {   ;# note this proc is at global :: scope

   470         variable test_ns_var::

   471         list [set {}] [info vars]

   472     }

   473     p

   474 } {{My name is empty} {{}}}

   475 test var-7.13 {Tcl_VariableObjCmd, variable named ":"} {

   476     namespace eval test_ns_var {

   477         variable : {My name is ":"}

   478 	proc p {} {

   479 	    variable :

   480 	    list [set :] [info vars]

   481 	}

   482 	p

   483     }

   484 } {{My name is ":"} :}

   485 test var-7.14 {Tcl_VariableObjCmd, array element parameter} {

   486     catch {namespace eval test_ns_var { variable arrayvar(1) }} res

   487     set res

   488 } "can't define \"arrayvar(1)\": name refers to an element in an array"

   489 test var-7.15 {Tcl_VariableObjCmd, array element parameter} {

   490     catch {

   491 	namespace eval test_ns_var {

   492 	    variable arrayvar

   493 	    set arrayvar(1) x

   494 	    variable arrayvar(1) y

   495 	}

   496     } res

   497     set res

   498 } "can't define \"arrayvar(1)\": name refers to an element in an array"

   499 test var-7.16 {Tcl_VariableObjCmd, no args} {

   500     list [catch {variable} msg] $msg

   501 } {1 {wrong # args: should be "variable ?name value...? name ?value?"}}

   502 test var-7.17 {Tcl_VariableObjCmd, no args} {

   503     namespace eval test_ns_var {

   504 	list [catch {variable} msg] $msg

   505     }

   506 } {1 {wrong # args: should be "variable ?name value...? name ?value?"}}

   508 test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} {

   509     catch {namespace delete test_ns_var}

   510     catch {unset a}

   511     namespace eval test_ns_var {

   512         variable v 123

   513         variable info ""

   515         proc traceUnset {name1 name2 op} {

   516             variable info

   517             set info [concat $info [list $name1 $name2 $op]]

   518         }

   520         trace var v u [namespace code traceUnset]

   521     }

   522     list [unset test_ns_var::v] $test_ns_var::info

   523 } {{} {test_ns_var::v {} u}}

   525 if {[info commands testsetnoerr] == {}} {

   526     puts "This application hasn't been compiled with the \"testsetnoerr\""

   527     puts "command, so I can't test TclSetVar etc."

   528 } else {

   529 test var-9.1 {behaviour of TclGet/SetVar simple get/set} {

   530     catch {unset u}; catch {unset v}

   531     list \

   532        [set u a; testsetnoerr u] \

   533        [testsetnoerr v b] \

   534        [testseterr u] \

   535        [unset v; testseterr v b]

   536 } [list {before get a} {before set b} {before get a} {before set b}]

   537 test var-9.2 {behaviour of TclGet/SetVar namespace get/set} {

   538     catch {namespace delete ns}

   539     namespace eval ns {variable u a; variable v}

   540     list \

   541        [testsetnoerr ns::u] \

   542        [testsetnoerr ns::v b] \

   543        [testseterr ns::u] \

   544        [unset ns::v; testseterr ns::v b]

   545 } [list {before get a} {before set b} {before get a} {before set b}]

   546 test var-9.3 {behaviour of TclGetVar no variable} {

   547     catch {unset u}

   548     list \

   549        [catch {testsetnoerr u} res] $res \

   550        [catch {testseterr u} res] $res

   551 } {1 {before get} 1 {can't read "u": no such variable}}

   552 test var-9.4 {behaviour of TclGetVar no namespace variable} {

   553     catch {namespace delete ns}

   554     namespace eval ns {}

   555     list \

   556        [catch {testsetnoerr ns::w} res] $res \

   557        [catch {testseterr ns::w} res] $res

   558 } {1 {before get} 1 {can't read "ns::w": no such variable}}

   559 test var-9.5 {behaviour of TclGetVar no namespace} {

   560     catch {namespace delete ns}

   561     list \

   562        [catch {testsetnoerr ns::u} res] $res \

   563        [catch {testseterr ns::v} res] $res

   564 } {1 {before get} 1 {can't read "ns::v": no such variable}}

   565 test var-9.6 {behaviour of TclSetVar no namespace} {

   566     catch {namespace delete ns}

   567     list \

   568        [catch {testsetnoerr ns::v 1} res] $res \

   569        [catch {testseterr ns::v 1} res] $res

   570 } {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}}

   571 test var-9.7 {behaviour of TclGetVar array variable} {

   572     catch {unset arr}

   573     set arr(1) 1;

   574     list \

   575        [catch {testsetnoerr arr} res] $res \

   576        [catch {testseterr arr} res] $res

   577 } {1 {before get} 1 {can't read "arr": variable is array}}

   578 test var-9.8 {behaviour of TclSetVar array variable} {

   579     catch {unset arr}

   580     set arr(1) 1

   581     list \

   582        [catch {testsetnoerr arr 2} res] $res \

   583        [catch {testseterr arr 2} res] $res

   584 } {1 {before set} 1 {can't set "arr": variable is array}}

   585 test var-9.9 {behaviour of TclGetVar read trace success} {

   586     proc resetvar {val name elem op} {upvar 1 $name v; set v $val}

   587     catch {unset u}; catch {unset v}

   588     set u 10

   589     trace var u r [list resetvar 1]

   590     trace var v r [list resetvar 2]

   591     list \

   592        [testsetnoerr u] \

   593        [testseterr v]

   594 } {{before get 1} {before get 2}}

   595 test var-9.10 {behaviour of TclGetVar read trace error} {

   596     proc writeonly args {error "write-only"}

   597     set v 456

   598     trace var v r writeonly

   599     list \

   600        [catch {testsetnoerr v} msg] $msg \

   601        [catch {testseterr v} msg] $msg

   602 } {1 {before get} 1 {can't read "v": write-only}}

   603 test var-9.11 {behaviour of TclSetVar write trace success} {

   604     proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]}

   605     catch {unset u}; catch {unset v}

   606     set v 1

   607     trace var v w doubleval

   608     trace var u w doubleval

   609     list \

   610        [testsetnoerr u 2] \

   611        [testseterr v 3]

   612 } {{before set 4} {before set 6}}

   613 test var-9.12 {behaviour of TclSetVar write trace error} {

   614     proc readonly args {error "read-only"}

   615     set v 456

   616     trace var v w readonly

   617     list \

   618        [catch {testsetnoerr v 2} msg] $msg $v \

   619        [catch {testseterr v 3} msg] $msg $v

   620 } {1 {before set} 2 1 {can't set "v": read-only} 3}

   621 }

   622 test var-10.1 {can't nest arrays with array set} {

   623    catch {unset arr}

   624    list [catch {array set arr(x) {a 1 b 2}} res] $res

   625 } {1 {can't set "arr(x)": variable isn't array}}

   627 test var-10.2 {can't nest arrays with array set} {

   628    catch {unset arr}

   629    list [catch {array set arr(x) {}} res] $res

   630 } {1 {can't set "arr(x)": variable isn't array}}

   632 test var-11.1 {array unset} {

   633     catch {unset a}

   634     array set a { 1,1 a 1,2 b 2,1 c 2,3 d }

   635     array unset a 1,*

   636     lsort -dict [array names a]

   637 } {2,1 2,3}

   638 test var-11.2 {array unset} {

   639     catch {unset a}

   640     array set a { 1,1 a 1,2 b }

   641     array unset a

   642     array exists a

   643 } 0

   644 test var-11.3 {array unset errors} {

   645     catch {unset a}

   646     array set a { 1,1 a 1,2 b }

   647     list [catch {array unset a pattern too} msg] $msg

   648 } {1 {wrong # args: should be "array unset arrayName ?pattern?"}}

   650 test var-12.1 {TclFindCompiledLocals, {} array name} {

   651     namespace eval n {

   652 	proc p {} {

   653 	    variable {}

   654 	    set (0) 0

   655 	    set (1) 1

   656 	    set n 2

   657 	    set ($n) 2

   658 	    set ($n,foo) 2

   659 	}

   660 	p

   661 	lsort -dictionary [array names {}]

   662     }

   663 } {0 1 2 2,foo}

   665 test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} {

   666     catch {unset t}

   667     proc foo {var ind op} {

   668 	global t

   669 	set foo bar

   670     }

   671     namespace eval :: {

   672 	set t(1) 1

   673 	trace variable t(1) u foo

   674 	unset t

   675     }

   676     set x "If you see this, it worked"

   677 } "If you see this, it worked"

   679 test var-14.1 {array names syntax} -body {

   680     array names foo bar baz snafu

   681 } -returnCodes 1 -match glob -result *

   683 test var-15.1 {segfault in [unset], [Bug 735335]} {

   684     proc A { name } {

   685 	upvar $name var

   686 	set var $name

   687     }

   688     #

   689     # Note that the variable name has to be

   690     # unused previously for the segfault to

   691     # be triggered.

   692     #

   693     namespace eval test A useSomeUnlikelyNameHere

   694     namespace eval test unset useSomeUnlikelyNameHere

   695 } {}

   697 test var-16.1 {CallVarTraces: save/restore interp error state: 1038021} {

   698     trace add variable errorCode write { ;#}

   699     catch {error foo bar baz}

   700     trace remove variable errorCode write { ;#}

   701     set errorInfo

   702 } bar

   704 test var-17.1 {TclArraySet [Bug 1669489]} -setup {

   705     unset -nocomplain ::a

   706 } -body {

   707     namespace eval :: {

   708         set elements {1 2 3 4}

   709         trace add variable a write {string length $elements ;#}

   710         array set a $elements

   711     }

   712 } -cleanup {

   713     unset -nocomplain ::a ::elements

   714 } -result {}

   716 catch {namespace delete ns}

   717 catch {unset arr}

   718 catch {unset v}

   720 catch {rename p ""}

   721 catch {namespace delete test_ns_var}

   722 catch {namespace delete test_ns_var2}

   723 catch {unset xx}

   724 catch {unset x}

   725 catch {unset y}

   726 catch {unset i}

   727 catch {unset a}

   728 catch {unset xxxxx}

   729 catch {unset aaaaa}

   731 # cleanup

   732 ::tcltest::cleanupTests

   733 return

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--