diff options
| -rw-r--r-- | ChangeLog | 4 | ||||
| -rw-r--r-- | tests/fCmd.test | 55 | ||||
| -rw-r--r-- | tests/safe.test | 40 | ||||
| -rw-r--r-- | tests/uplevel.test | 53 | ||||
| -rw-r--r-- | tests/upvar.test | 181 | ||||
| -rw-r--r-- | tests/var.test | 378 |
6 files changed, 363 insertions, 348 deletions
@@ -1,5 +1,9 @@ 2010-12-07 Donal K. Fellows <dkf@users.sf.net> + * tests/fCmd.test, tests/safe.test, tests/uplevel.test, + * tests/upvar.test, tests/var.test: Convert more tests to tcltest2 and + factor them to be easier to understand. + * generic/tclStrToD.c: Tidy up code so that more #ifdef-fery is quarantined at the front of the file and function headers follow the modern Tcl style. diff --git a/tests/fCmd.test b/tests/fCmd.test index 1436a28..4057cd0 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -10,10 +10,10 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fCmd.test,v 1.70 2009/11/24 00:08:27 patthoyts Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.71 2010/12/07 16:32:06 dkf Exp $ # -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -31,7 +31,10 @@ testConstraint reg 0 if {[testConstraint win]} { catch { # Is the registry extension already static to this shell? - if [catch {load {} Registry; set ::reglib {}}] { + try { + load {} Registry + set ::reglib {} + } on error {} { # try the location given to use on the commandline to tcltest ::tcltest::loadTestedCommands load $::reglib Registry @@ -106,11 +109,11 @@ proc createfile {file {string a}} { # if the file does not exist, or has a different content # proc checkcontent {file matchString} { - if {[catch { + try { set f [open $file] set fileString [read $f] close $f - }]} then { + } on error {} { return 0 } return [string match $matchString $fileString] @@ -163,8 +166,8 @@ testConstraint xdev [expr {[testConstraint unix] && ([dev .] != [dev /tmp])}] set root [lindex [file split [pwd]] 0] -# A really long file name -# length of long is 1216 chars, which should be greater than any static buffer +# A really long file name. +# Length of long is 1216 chars, which should be greater than any static buffer # or allowable filename. set long "abcdefghihjllmnopqrstuvwxyz01234567890" @@ -173,7 +176,7 @@ append long $long append long $long append long $long append long $long - + test fCmd-1.1 {TclFileRenameCmd} -constraints {notRoot} -setup { cleanup } -body { @@ -1529,8 +1532,7 @@ test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} -setup { set ::env(HOME) $temp } -result {1} # -# Can Tcl_SplitPath return argc == 0? If so them we need a -# test for that code. +# Can Tcl_SplitPath return argc == 0? If so them we need a test for that code. # test fCmd-15.2 {TclMakeDirsCmd - one directory} -setup { catch {file delete -force -- tfa} @@ -1710,7 +1712,6 @@ test fCmd-17.3 {mkdir several levels deep - absolute} -setup { # # Functionality tests for TclFileRenameCmd() # - test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} \ -setup { catch {file delete -force -- tfad} @@ -1918,7 +1919,6 @@ test fCmd-19.3 {recursive remove} -constraints {notRoot} -setup { # # Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd # - test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory} -setup { catch {file delete -force -- tfa} } -constraints {unix notRoot} -body { @@ -2150,7 +2150,6 @@ test fCmd-22.5 {TclMacCopyFile: copy and overwrite in a single dir} -setup { # TclMacRmdir # Error cases are not covered. # - test fCmd-23.1 {TclMacRmdir: trying to remove a nonempty directory} -setup { catch {file delete -force -- tfad} } -constraints {notRoot} -body { @@ -2212,7 +2211,6 @@ test fCmd-25.3 {TclMacCopyDirectory: copying dirs between different dirs} -setup # # Functionality tests for TclDeleteFilesCmd # - test fCmd-26.1 {TclDeleteFilesCmd: delete symlink} -setup { catch {file delete -force -- tfad1 tfad2} } -constraints {unix notRoot} -body { @@ -2405,7 +2403,7 @@ test fCmd-28.12 {file link: cd into a link} -setup { cd .. set up [pwd] cd $orig - # now '$up' should be either $orig or [file dirname abc.dir], depending on + # Now '$up' should be either $orig or [file dirname abc.dir], depending on # whether 'cd' actually moves to the destination of a link, or simply # treats the link as a directory. (On windows the former, on unix the # latter, I believe) @@ -2530,22 +2528,23 @@ test fCmd-28.22 {file link: relative paths} -setup { catch {file delete -force d1} cd [workingDirectory] } -result d2/d3 - -test fCmd-29.1 {weird memory corruption fault} -body { - open [file join ~a_totally_bogus_user_id/foo bar] -} -returnCodes error -match glob -result * - -cd [temporaryDirectory] -file delete -force abc.link -file delete -force d1/d2 -file delete -force d1 -cd [workingDirectory] - +try { + cd [temporaryDirectory] + file delete -force abc.link + file delete -force d1/d2 + file delete -force d1 +} finally { + cd [workingDirectory] +} removeFile abc2.file removeFile abc.file removeDirectory abc2.dir removeDirectory abc.dir +test fCmd-29.1 {weird memory corruption fault} -body { + open [file join ~a_totally_bogus_user_id/foo bar] +} -returnCodes error -match glob -result * + test fCmd-30.1 {file writable on 'My Documents'} -setup { # Get the localized version of the folder name by looking in the registry. set mydocsname [registry get {HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders} Personal] @@ -2556,7 +2555,6 @@ test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {2000orNewer} -body expr {[info exists env(USERPROFILE)] && [file exists $env(USERPROFILE)/NTUSER.DAT] && [file readable $env(USERPROFILE)/NTUSER.DAT]} - } -result {1} test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {2000orNewer} -body { set r {} @@ -2568,7 +2566,7 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {2000orNewer} -bod } return $r } -result {exists 1 readable 0 stat 0 {}} - + # cleanup cleanup ::tcltest::cleanupTests @@ -2576,4 +2574,5 @@ return # Local Variables: # mode: tcl +# fill-column: 78 # End: diff --git a/tests/safe.test b/tests/safe.test index 14cd021..5025469 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.test,v 1.35 2010/11/02 21:42:28 stwo Exp $ +# RCS: @(#) $Id: safe.test,v 1.36 2010/12/07 16:32:06 dkf Exp $ package require Tcl 8.5 @@ -31,6 +31,11 @@ set ::auto_path [info library] catch {safe::interpConfigure} proc equiv {x} {return $x} + +# testing that nested and statics do what is advertised (we use a static +# package - Tcltest - but it might be absent if we're in standard tclsh) + +testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { safe::interpConfigure @@ -166,27 +171,24 @@ test safe-6.2 {test safe interpreters knowledge of the world} { SafeEval {info script} } {} test safe-6.3 {test safe interpreters knowledge of the world} { - set r [lsort [SafeEval {array names tcl_platform}]] + set r [SafeEval {array names tcl_platform}] # If running a windows-debug shell, remove the "debug" element from r. - if {[testConstraint win] && ("debug" in $r)} { - set r [lreplace $r 1 1] - } - set threaded [lsearch $r "threaded"] - if {$threaded != -1} { - set r [lreplace $r $threaded $threaded] + if {[testConstraint win]} { + set r [lsearch -all -inline -not -exact $r "debug"] } - set r + set r [lsearch -all -inline -not -exact $r "threaded"] + lsort $r } {byteOrder pathSeparator platform pointerSize wordSize} -# more test should be added to check that hostname, nameofexecutable, -# aren't leaking infos, but they still do... +# More test should be added to check that hostname, nameofexecutable, aren't +# leaking infos, but they still do... # high level general test test safe-7.1 {tests that everything works at high level} { set i [safe::interpCreate] # no error shall occur: - # (because the default access_path shall include 1st level sub dirs - # so package require in a slave works like in the master) + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) set v [interp eval $i {package require http 1}] # no error shall occur: interp eval $i {http_config} @@ -400,17 +402,7 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i] } -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} -# testing that nested and statics do what is advertised (we use a static -# package : Tcltest) -try { - package require Tcltest - testConstraint TcltestPackage 1 - # we use the Tcltest package , which has no Safe_Init -} on error {} { - testConstraint TcltestPackage 0 -} - -teststaticpkg Safepkg1 0 0 +catch {teststaticpkg Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { diff --git a/tests/uplevel.test b/tests/uplevel.test index f676290..0413a47 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -1,17 +1,17 @@ # Commands covered: uplevel # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: uplevel.test,v 1.9 2008/06/08 03:21:33 msofer Exp $ +# RCS: @(#) $Id: uplevel.test,v 1.10 2010/12/07 16:32:06 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -26,7 +26,7 @@ proc newset {name value} { uplevel set $name $value uplevel 1 {uplevel 1 {set xyz 22}} } - + test uplevel-1.1 {simple operation} { set xyz 0 a 22 33 @@ -85,20 +85,24 @@ test uplevel-3.4 {uplevel to same level} { a1 } 55 -test uplevel-4.1 {error: non-existent level} { - list [catch c1 msg] $msg -} {1 {bad level "#2"}} -test uplevel-4.2 {error: non-existent level} { - proc c2 {} {uplevel 3 {set a b}} - list [catch c2 msg] $msg -} {1 {bad level "3"}} -test uplevel-4.3 {error: not enough args} { - list [catch uplevel msg] $msg -} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} -test uplevel-4.4 {error: not enough args} { - proc upBug {} {uplevel 1} - list [catch upBug msg] $msg -} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} +test uplevel-4.1 {error: non-existent level} -returnCodes error -body { + apply {{} { + uplevel #2 {set y 222} + }} +} -result {bad level "#2"} +test uplevel-4.2 {error: non-existent level} -returnCodes error -body { + apply {{} { + uplevel 3 {set a b} + }} +} -result {bad level "3"} +test uplevel-4.3 {error: not enough args} -returnCodes error -body { + uplevel +} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} +test uplevel-4.4 {error: not enough args} -returnCodes error -body { + apply {{} { + uplevel 1 + }} +} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} proc a2 {} { uplevel a3 @@ -193,7 +197,12 @@ test uplevel-7.3 {var access, LVT in upper level} -setup { rename foo {} rename moo {} } -result {3 3 3} - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/upvar.test b/tests/upvar.test index dbf6dd5..90ba0b1 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: upvar.test,v 1.20 2010/02/10 23:28:39 dkf Exp $ +# RCS: @(#) $Id: upvar.test,v 1.21 2010/12/07 16:32:06 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -427,116 +427,103 @@ namespace eval test_ns_0 { } set ::x test_global -test upvar-NS-1.1 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { +test upvar-NS-1.1 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace upvar ::test_ns_0 x w + set w + } +} -result {test_ns_0} -cleanup { + namespace delete test_ns_1 +} +test upvar-NS-1.2 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + proc a {} { namespace upvar ::test_ns_0 x w set w } - } \ - -result {test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.2 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - proc a {} { - namespace upvar ::test_ns_0 x w - set w - } - return [a] - } - } \ - -result {test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.3 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { + return [a] + } +} -result {test_ns_0} -cleanup { + namespace delete test_ns_1 +} +test upvar-NS-1.3 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace upvar test_ns_0 x w + set w + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::test_ns_1"} +test upvar-NS-1.4 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + proc a {} { namespace upvar test_ns_0 x w set w } - } \ - -result {namespace "test_ns_0" not found in "::test_ns_1"} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.4 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] - } - } \ - -result {namespace "test_ns_0" not found in "::test_ns_1"} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.5 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 {} + return [a] + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::test_ns_1"} + +test upvar-NS-1.5 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 {} + namespace upvar test_ns_0 x w + set w + } +} -cleanup { + namespace delete test_ns_1 +} -result {can't read "w": no such variable} -returnCodes error +test upvar-NS-1.6 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 {} + proc a {} { namespace upvar test_ns_0 x w set w } - } \ - -result {can't read "w": no such variable} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.6 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 {} - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] + return [a] + } +} -cleanup { + namespace delete test_ns_1 +} -result {can't read "w": no such variable} -returnCodes error +test upvar-NS-1.7 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 { + variable x test_ns_1::test_ns_0 + } + namespace upvar test_ns_0 x w + set w + } +} -cleanup { + namespace delete test_ns_1 +} -result {test_ns_1::test_ns_0} +test upvar-NS-1.8 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 { + variable x test_ns_1::test_ns_0 } - } \ - -result {can't read "w": no such variable} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.7 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 { - variable x test_ns_1::test_ns_0 - } + proc a {} { namespace upvar test_ns_0 x w set w } - } \ - -result {test_ns_1::test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.8 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 { - variable x test_ns_1::test_ns_0 - } - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] - } - } \ - -result {test_ns_1::test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.9 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - variable x test_ns_1 - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] + return [a] + } +} -cleanup { + namespace delete test_ns_1 +} -result {test_ns_1::test_ns_0} +test upvar-NS-1.9 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + variable x test_ns_1 + proc a {} { + namespace upvar test_ns_0 x w + set w } - } \ - -result {namespace "test_ns_0" not found in "::test_ns_1"} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} + return [a] + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::test_ns_1"} test upvar-NS-2.1 {TIP 323} -returnCodes error -body { namespace upvar diff --git a/tests/var.test b/tests/var.test index dd9483b..01be5a4 100644 --- a/tests/var.test +++ b/tests/var.test @@ -1,23 +1,23 @@ -# This file contains tests for the tclVar.c source file. Tests appear in -# the same order as the C code that they test. The set of tests is -# currently incomplete since it currently includes only new tests for -# code changed for the addition of Tcl namespaces. Other variable- -# related tests appear in several other test files including -# namespace.test, set.test, trace.test, and upvar.test. +# This file contains tests for the tclVar.c source file. Tests appear in the +# same order as the C code that they test. The set of tests is currently +# incomplete since it currently includes only new tests for code changed for +# the addition of Tcl namespaces. Other variable-related tests appear in +# several other test files including namespace.test, set.test, trace.test, and +# upvar.test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: var.test,v 1.36 2010/08/03 17:25:13 andreas_kupries Exp $ +# RCS: @(#) $Id: var.test,v 1.37 2010/12/07 16:32:06 dkf Exp $ # -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -35,13 +35,14 @@ catch {unset i} catch {unset a} catch {unset arr} -test var-1.1 {TclLookupVar, Array handling} { +test var-1.1 {TclLookupVar, Array handling} -setup { catch {unset a} +} -body { set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd set i 10 set arr(foo) 37 list [$x i] $i [$x arr(foo)] $arr(foo) -} {11 11 38 38} +} -result {11 11 38 38} test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { set x "global value" namespace eval test_ns_var { @@ -71,34 +72,35 @@ test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} { namespace eval test_ns_var {set ::x} } {global value} -test var-1.7 {TclLookupVar, error finding namespace var} { - list [catch {set a:::b} msg] $msg -} {1 {can't read "a:::b": no such variable}} -test var-1.8 {TclLookupVar, error finding namespace var} { - list [catch {set ::foobarfoo} msg] $msg -} {1 {can't read "::foobarfoo": no such variable}} +test var-1.7 {TclLookupVar, error finding namespace var} -body { + set a:::b +} -returnCodes error -result {can't read "a:::b": no such variable} +test var-1.8 {TclLookupVar, error finding namespace var} -body { + set ::foobarfoo +} -returnCodes error -result {can't read "::foobarfoo": no such variable} test var-1.9 {TclLookupVar, create new namespace var} { namespace eval test_ns_var { set v hello } } {hello} -test var-1.10 {TclLookupVar, create new namespace var} { +test var-1.10 {TclLookupVar, create new namespace var} -setup { catch {unset y} +} -body { namespace eval test_ns_var { set ::y 789 } set y -} {789} -test var-1.11 {TclLookupVar, error creating new namespace var} { +} -result {789} +test var-1.11 {TclLookupVar, error creating new namespace var} -body { namespace eval test_ns_var { - list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg + set ::test_ns_var::foo::bar 314159 } -} {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}} -test var-1.12 {TclLookupVar, error creating new namespace var} { +} -returnCodes error -result {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist} +test var-1.12 {TclLookupVar, error creating new namespace var} -body { namespace eval test_ns_var { - list [catch {set ::test_ns_var::foo:: 1997} msg] $msg + set ::test_ns_var::foo:: 1997 } -} {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}} +} -returnCodes error -result {can't set "::test_ns_var::foo::": parent namespace doesn't exist} test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} { catch {unset aNeWnAmEiNnS} namespace eval test_ns_var { @@ -177,24 +179,25 @@ test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: set result } } {0 2 1 {can't set "foo": upvar refers to element in deleted array}} -test var-1.19 {TclLookupVar, right error message when parsing variable name} { - list [catch {[format set] thisvar(doesntexist)} msg] $msg -} {1 {can't read "thisvar(doesntexist)": no such variable}} +test var-1.19 {TclLookupVar, right error message when parsing variable name} -body { + [format set] thisvar(doesntexist) +} -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} test var-2.1 {Tcl_LappendObjCmd, create var if new} { catch {unset x} lappend x 1 2 } {1 2} -test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} { +test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup { catch {unset x} +} -body { set x 1997 proc p {} { global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x return $x } p -} {1997} +} -result {1997} test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { namespace eval test_ns_var { catch {unset v} @@ -206,17 +209,19 @@ test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { p } } {1998} -test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} testupvar { +test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { catch {unset a} +} -constraints testupvar -body { set a 123321 proc p {} { # create global xx linked to global a testupvar 1 a {} xx global } list [p] $xx [set xx 789] $a -} {{} 123321 789 789} -test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} testupvar { +} -result {{} 123321 789 789} +test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { catch {unset a} +} -constraints testupvar -body { set a 456 namespace eval test_ns_var { catch {unset ::test_ns_var::vv} @@ -227,58 +232,64 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} testupvar { p } list $test_ns_var::vv [set test_ns_var::vv 123] $a -} {456 123 123} -test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} { +} -result {456 123 123} +test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { catch {unset aaaaa} catch {unset xxxxx} +} -body { set aaaaa 77777 upvar #0 aaaaa xxxxx list [set xxxxx] [set aaaaa] -} {77777 77777} -test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} { +} -result {77777 77777} +test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup { catch {unset a} +} -body { set a 121212 namespace eval test_ns_var { upvar ::a vvv set vvv } -} {121212} -test var-3.7 {MakeUpvar, my var has ::s} { +} -result {121212} +test var-3.7 {MakeUpvar, my var has ::s} -setup { catch {unset a} +} -body { set a 789789 upvar #0 a test_ns_var::lnk namespace eval test_ns_var { set lnk } -} {789789} -test var-3.8 {MakeUpvar, my var already exists in global ns} { +} -result {789789} +test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { catch {unset aaaaa} catch {unset xxxxx} +} -body { set aaaaa 456654 set xxxxx hello upvar #0 aaaaa xxxxx set xxxxx -} {hello} -test var-3.9 {MakeUpvar, my var has invalid ns name} { +} -result {hello} +test var-3.9 {MakeUpvar, my var has invalid ns name} -setup { catch {unset aaaaa} +} -returnCodes error -body { set aaaaa 789789 - list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg -} {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}} -test var-3.10 {MakeUpvar, } { + upvar #0 aaaaa test_ns_fred::lnk +} -result {can't create "test_ns_fred::lnk": parent namespace doesn't exist} +test var-3.10 {MakeUpvar, between namespaces} -body { namespace eval {} { - set bar 0 + variable bar 0 namespace eval foo upvar bar bar set foo::bar 1 - catch {list $bar $foo::bar} msg - unset ::aaaaa - set msg + list $bar $foo::bar } -} {1 1} -test var-3.11 {MakeUpvar, my var looks like array elem} -body { +} -cleanup { + unset ::aaaaa +} -result {1 1} +test var-3.11 {MakeUpvar, my var looks like array elem} -setup { catch {unset aaaaa} +} -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa foo(bar) -} -returnCodes 1 -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} +} -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { catch {unset a} @@ -291,17 +302,19 @@ test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname { testgetvarfullname george namespace } } ::test_ns_var::george -test var-4.3 {Tcl_GetVariableName, variable can't be array element} testgetvarfullname { +test var-4.3 {Tcl_GetVariableName, variable can't be array element} -setup { catch {unset a} +} -constraints testgetvarfullname -body { set a(1) foo - list [catch {testgetvarfullname a(1) global} msg] $msg -} {1 {unknown variable "a(1)"}} + testgetvarfullname a(1) global +} -returnCodes error -result {unknown variable "a(1)"} -test var-5.1 {Tcl_GetVariableFullName, global variable} { +test var-5.1 {Tcl_GetVariableFullName, global variable} -setup { catch {unset a} +} -body { set a bar namespace which -variable a -} {::a} +} -result {::a} test var-5.2 {Tcl_GetVariableFullName, namespace variable} { namespace eval test_ns_var { variable martha @@ -316,11 +329,10 @@ test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { namespace eval test_ns_var { variable boeing 777 } - proc p {} { + apply {{} { global ::test_ns_var::boeing set boeing - } - p + }} } {777} test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { namespace eval test_ns_var { @@ -336,11 +348,10 @@ test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { } {java} test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} { set ::test_ns_var::test_ns_nested:: 24 - proc p {} { + apply {{} { global ::test_ns_var::test_ns_nested:: set {} - } - p + }} } {24} test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} { # Test for Tcl Bug 480176 @@ -362,13 +373,14 @@ test var-6.6 {Tcl_GlobalObjCmd, no-op case (TIP 323)} { p } {} -test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} { +test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} -setup { catch {namespace delete test_ns_var} +} -body { namespace eval test_ns_var { variable one 1 } list [info vars test_ns_var::*] [set test_ns_var::one] -} {::test_ns_var::one 1} +} -result {::test_ns_var::one 1} test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} { set two 2222222 namespace eval test_ns_var { @@ -390,10 +402,11 @@ test var-7.4 {Tcl_VariableObjCmd, list of vars} { list [lsort [info vars test_ns_var::*]] \ [namespace eval test_ns_var {expr $three+$four}] } [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] -test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} { +test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { catch {unset a} catch {unset five} catch {unset six} +} -body { set a "" set five 555 set six 666 @@ -403,23 +416,25 @@ test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} { } lappend a $test_ns_var::five \ [set test_ns_var::six 6] [set test_ns_var::six] $six +} -cleanup { catch {unset five} catch {unset six} - set a -} {5 5 6 6 666} -catch {unset newvar} -test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} { +} -result {5 5 6 6 666} +test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} -setup { + catch {unset newvar} +} -body { namespace eval test_ns_var { variable ::newvar cheers! } - set newvar -} {cheers!} -catch {unset newvar} -test var-7.7 {Tcl_VariableObjCmd, bad var name} { + return $newvar +} -cleanup { + catch {unset newvar} +} -result {cheers!} +test var-7.7 {Tcl_VariableObjCmd, bad var name} -returnCodes error -body { namespace eval test_ns_var { - list [catch {variable sev:::en 7} msg] $msg + variable sev:::en 7 } -} {1 {can't define "sev:::en": parent namespace doesn't exist}} +} -result {can't define "sev:::en": parent namespace doesn't exist} test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} { set a "" namespace eval test_ns_var { @@ -430,8 +445,9 @@ test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, l } set a } {8 8} -test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} { +test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup { catch {namespace delete test_ns_var2} +} -body { set a "" namespace eval test_ns_var2 { variable x 123 @@ -451,8 +467,7 @@ test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until na lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] lappend a [list [catch {unset test_ns_var2::z} msg] $msg] lappend a [namespace delete test_ns_var2] - set a -} [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\ +} -result [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\ {1 {can't read "test_ns_var2::y": no such variable}}\ [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\ hello 1 0\ @@ -496,20 +511,16 @@ test var-7.13 {Tcl_VariableObjCmd, variable named ":"} { p } } {{My name is ":"} :} -test var-7.14 {Tcl_VariableObjCmd, array element parameter} { - catch {namespace eval test_ns_var { variable arrayvar(1) }} res - set res -} "can't define \"arrayvar(1)\": name refers to an element in an array" -test var-7.15 {Tcl_VariableObjCmd, array element parameter} { - catch { - namespace eval test_ns_var { - variable arrayvar - set arrayvar(1) x - variable arrayvar(1) y - } - } res - set res -} "can't define \"arrayvar(1)\": name refers to an element in an array" +test var-7.14 {Tcl_VariableObjCmd, array element parameter} -body { + namespace eval test_ns_var { variable arrayvar(1) } +} -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" +test var-7.15 {Tcl_VariableObjCmd, array element parameter} -body { + namespace eval test_ns_var { + variable arrayvar + set arrayvar(1) x + variable arrayvar(1) y + } +} -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" test var-7.16 {Tcl_VariableObjCmd, no args (TIP 323)} { variable } {} @@ -519,158 +530,173 @@ test var-7.17 {Tcl_VariableObjCmd, no args (TIP 323)} { } } {} -test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} { +test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} catch {unset a} +} -body { namespace eval test_ns_var { variable v 123 variable info "" - proc traceUnset {name1 name2 op} { variable info set info [concat $info [list $name1 $name2 $op]] } - trace var v u [namespace code traceUnset] } list [unset test_ns_var::v] $test_ns_var::info -} {{} {test_ns_var::v {} u}} - -test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} { +} -result {{} {test_ns_var::v {} u}} +test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} catch {unset a} +} -body { set info "" namespace eval test_ns_var { variable v 123 1 trace var v u ::traceUnset } - proc traceUnset {name1 name2 op} { set ::info [concat $::info [list $name1 $name2 $op]] } - list [namespace delete test_ns_var] $::info -} {{} {::test_ns_var::v {} u}} +} -result {{} {::test_ns_var::v {} u}} -test var-9.1 {behaviour of TclGet/SetVar simple get/set} testsetnoerr { - catch {unset u}; catch {unset v} +test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { + catch {unset u} + catch {unset v} +} -constraints testsetnoerr -body { list \ - [set u a; testsetnoerr u] \ - [testsetnoerr v b] \ - [testseterr u] \ - [unset v; testseterr v b] -} [list {before get a} {before set b} {before get a} {before set b}] -test var-9.2 {behaviour of TclGet/SetVar namespace get/set} testsetnoerr { + [set u a; testsetnoerr u] \ + [testsetnoerr v b] \ + [testseterr u] \ + [unset v; testseterr v b] +} -result [list {before get a} {before set b} {before get a} {before set b}] +test var-9.2 {behaviour of TclGet/SetVar namespace get/set} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { namespace eval ns {variable u a; variable v} list \ - [testsetnoerr ns::u] \ - [testsetnoerr ns::v b] \ - [testseterr ns::u] \ - [unset ns::v; testseterr ns::v b] -} [list {before get a} {before set b} {before get a} {before set b}] -test var-9.3 {behaviour of TclGetVar no variable} testsetnoerr { + [testsetnoerr ns::u] \ + [testsetnoerr ns::v b] \ + [testseterr ns::u] \ + [unset ns::v; testseterr ns::v b] +} -result [list {before get a} {before set b} {before get a} {before set b}] +test var-9.3 {behaviour of TclGetVar no variable} -setup { catch {unset u} +} -constraints testsetnoerr -body { list \ - [catch {testsetnoerr u} res] $res \ - [catch {testseterr u} res] $res -} {1 {before get} 1 {can't read "u": no such variable}} -test var-9.4 {behaviour of TclGetVar no namespace variable} testsetnoerr { + [catch {testsetnoerr u} res] $res \ + [catch {testseterr u} res] $res +} -result {1 {before get} 1 {can't read "u": no such variable}} +test var-9.4 {behaviour of TclGetVar no namespace variable} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { namespace eval ns {} list \ - [catch {testsetnoerr ns::w} res] $res \ - [catch {testseterr ns::w} res] $res -} {1 {before get} 1 {can't read "ns::w": no such variable}} -test var-9.5 {behaviour of TclGetVar no namespace} testsetnoerr { + [catch {testsetnoerr ns::w} res] $res \ + [catch {testseterr ns::w} res] $res +} -result {1 {before get} 1 {can't read "ns::w": no such variable}} +test var-9.5 {behaviour of TclGetVar no namespace} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { list \ - [catch {testsetnoerr ns::u} res] $res \ - [catch {testseterr ns::v} res] $res -} {1 {before get} 1 {can't read "ns::v": no such variable}} -test var-9.6 {behaviour of TclSetVar no namespace} testsetnoerr { + [catch {testsetnoerr ns::u} res] $res \ + [catch {testseterr ns::v} res] $res +} -result {1 {before get} 1 {can't read "ns::v": no such variable}} +test var-9.6 {behaviour of TclSetVar no namespace} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { list \ - [catch {testsetnoerr ns::v 1} res] $res \ - [catch {testseterr ns::v 1} res] $res -} {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} -test var-9.7 {behaviour of TclGetVar array variable} testsetnoerr { + [catch {testsetnoerr ns::v 1} res] $res \ + [catch {testseterr ns::v 1} res] $res +} -result {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} +test var-9.7 {behaviour of TclGetVar array variable} -setup { catch {unset arr} - set arr(1) 1; +} -constraints testsetnoerr -body { + set arr(1) 1 list \ - [catch {testsetnoerr arr} res] $res \ - [catch {testseterr arr} res] $res -} {1 {before get} 1 {can't read "arr": variable is array}} -test var-9.8 {behaviour of TclSetVar array variable} testsetnoerr { + [catch {testsetnoerr arr} res] $res \ + [catch {testseterr arr} res] $res +} -result {1 {before get} 1 {can't read "arr": variable is array}} +test var-9.8 {behaviour of TclSetVar array variable} -setup { catch {unset arr} +} -constraints testsetnoerr -body { set arr(1) 1 list \ - [catch {testsetnoerr arr 2} res] $res \ - [catch {testseterr arr 2} res] $res -} {1 {before set} 1 {can't set "arr": variable is array}} -test var-9.9 {behaviour of TclGetVar read trace success} testsetnoerr { + [catch {testsetnoerr arr 2} res] $res \ + [catch {testseterr arr 2} res] $res +} -result {1 {before set} 1 {can't set "arr": variable is array}} +test var-9.9 {behaviour of TclGetVar read trace success} -setup { + catch {unset u} + catch {unset v} +} -constraints testsetnoerr -body { proc resetvar {val name elem op} {upvar 1 $name v; set v $val} - catch {unset u}; catch {unset v} set u 10 trace var u r [list resetvar 1] trace var v r [list resetvar 2] list \ - [testsetnoerr u] \ - [testseterr v] -} {{before get 1} {before get 2}} + [testsetnoerr u] \ + [testseterr v] +} -result {{before get 1} {before get 2}} test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { proc writeonly args {error "write-only"} set v 456 trace var v r writeonly list \ - [catch {testsetnoerr v} msg] $msg \ - [catch {testseterr v} msg] $msg + [catch {testsetnoerr v} msg] $msg \ + [catch {testseterr v} msg] $msg } {1 {before get} 1 {can't read "v": write-only}} -test var-9.11 {behaviour of TclSetVar write trace success} testsetnoerr { +test var-9.11 {behaviour of TclSetVar write trace success} -setup { + catch {unset u} + catch {unset v} +} -constraints testsetnoerr -body { proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} - catch {unset u}; catch {unset v} set v 1 trace var v w doubleval trace var u w doubleval list \ - [testsetnoerr u 2] \ - [testseterr v 3] -} {{before set 4} {before set 6}} + [testsetnoerr u 2] \ + [testseterr v 3] +} -result {{before set 4} {before set 6}} test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { proc readonly args {error "read-only"} set v 456 trace var v w readonly list \ - [catch {testsetnoerr v 2} msg] $msg $v \ - [catch {testseterr v 3} msg] $msg $v + [catch {testsetnoerr v 2} msg] $msg $v \ + [catch {testseterr v 3} msg] $msg $v } {1 {before set} 2 1 {can't set "v": read-only} 3} -test var-10.1 {can't nest arrays with array set} { +test var-10.1 {can't nest arrays with array set} -setup { catch {unset arr} - list [catch {array set arr(x) {a 1 b 2}} res] $res -} {1 {can't set "arr(x)": variable isn't array}} -test var-10.2 {can't nest arrays with array set} { +} -returnCodes error -body { + array set arr(x) {a 1 b 2} +} -result {can't set "arr(x)": variable isn't array} +test var-10.2 {can't nest arrays with array set} -setup { catch {unset arr} - list [catch {array set arr(x) {}} res] $res -} {1 {can't set "arr(x)": variable isn't array}} +} -returnCodes error -body { + array set arr(x) {} +} -result {can't set "arr(x)": variable isn't array} -test var-11.1 {array unset} { +test var-11.1 {array unset} -setup { catch {unset a} +} -body { array set a { 1,1 a 1,2 b 2,1 c 2,3 d } array unset a 1,* lsort -dict [array names a] -} {2,1 2,3} -test var-11.2 {array unset} { +} -result {2,1 2,3} +test var-11.2 {array unset} -setup { catch {unset a} +} -body { array set a { 1,1 a 1,2 b } array unset a array exists a -} 0 -test var-11.3 {array unset errors} { +} -result 0 +test var-11.3 {array unset errors} -setup { catch {unset a} +} -returnCodes error -body { array set a { 1,1 a 1,2 b } - list [catch {array unset a pattern too} msg] $msg -} {1 {wrong # args: should be "array unset arrayName ?pattern?"}} + array unset a pattern too +} -result {wrong # args: should be "array unset arrayName ?pattern?"} test var-12.1 {TclFindCompiledLocals, {} array name} { namespace eval n { @@ -687,8 +713,9 @@ test var-12.1 {TclFindCompiledLocals, {} array name} { } } {0 1 2 2,foo} -test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} { +test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { catch {unset t} +} -body { proc foo {var ind op} { global t set foo bar @@ -699,15 +726,14 @@ test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} { unset t } set x "If you see this, it worked" -} "If you see this, it worked" +} -result "If you see this, it worked" test var-14.1 {array names syntax} -body { array names foo bar baz snafu } -returnCodes 1 -match glob -result * - test var-14.2 {array names -glob} -body { array names tcl_platform -glob os -} -returnCodes 0 -match exact -result os +} -result os test var-15.1 {segfault in [unset], [Bug 735335]} { proc A { name } { @@ -723,7 +749,6 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test unset useSomeUnlikelyNameHere } {} - test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" catch {error foo bar baz} @@ -763,7 +788,6 @@ test var-18.1 {array unset and unset traces: Bug 2939073} -setup { unset x already } -result 0 - test var-19.1 {crash when freeing locals hashtable: Bug 3037525} { proc foo {} { catch {upvar 0 dummy \$index} } foo ; # This crashes without the fix for the bug |