diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/cmdAH.test | 82 | ||||
| -rw-r--r-- | tests/cmdMZ.test | 58 | ||||
| -rw-r--r-- | tests/compExpr.test | 215 | ||||
| -rw-r--r-- | tests/compile.test | 257 | ||||
| -rw-r--r-- | tests/concat.test | 23 | ||||
| -rw-r--r-- | tests/eval.test | 23 | ||||
| -rw-r--r-- | tests/fileName.test | 20 | ||||
| -rw-r--r-- | tests/fileSystem.test | 2 | ||||
| -rw-r--r-- | tests/interp.test | 8 | ||||
| -rw-r--r-- | tests/lsearch.test | 104 | ||||
| -rw-r--r-- | tests/namespace-old.test | 12 | ||||
| -rw-r--r-- | tests/namespace.test | 88 | ||||
| -rw-r--r-- | tests/oo.test | 6 | ||||
| -rw-r--r-- | tests/proc.test | 357 | ||||
| -rw-r--r-- | tests/security.test | 16 | ||||
| -rw-r--r-- | tests/switch.test | 8 | ||||
| -rw-r--r-- | tests/unixInit.test | 88 | ||||
| -rw-r--r-- | tests/var.test | 8 | ||||
| -rw-r--r-- | tests/winDde.test | 8 | ||||
| -rw-r--r-- | tests/winPipe.test | 19 |
20 files changed, 703 insertions, 699 deletions
diff --git a/tests/cmdAH.test b/tests/cmdAH.test index ab388b9..068b6cd 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,9 +10,9 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.69 2010/12/09 15:09:08 dkf Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.70 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -236,14 +236,15 @@ test cmdAH-6.1 {Tcl_FileObjCmd: volumes} -returnCodes error -body { test cmdAH-6.2 {Tcl_FileObjCmd: volumes} -body { lindex [file volumes] 0 } -match glob -result ?* -test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {unix} { +test cmdAH-6.3 {Tcl_FileObjCmd: volumes} -constraints unix -body { set volumeList [file volumes] - catch [list glob -nocomplain [lindex $volumeList 0]*] -} {0} -test cmdAH-6.4 {Tcl_FileObjCmd: volumes} win { + glob -nocomplain [lindex $volumeList 0]* +} -match glob -result * +test cmdAH-6.4 {Tcl_FileObjCmd: volumes} -constraints win -body { set volumeList [string tolower [file volumes]] - list [catch {lsearch $volumeList "c:/"} element] [expr {$element != -1}] [catch {list glob -nocomplain [lindex $volumeList $element]*}] -} {0 1 0} + set element [lsearch -exact $volumeList "c:/"] + list [expr {$element>-1}] [glob -nocomplain [lindex $volumeList $element]*] +} -match glob -result {1 *} # attributes test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} -setup { @@ -251,11 +252,11 @@ test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} -setup { catch {file delete -force $foofile} } -body { close [open $foofile w] - catch {file attributes $foofile} + file attributes $foofile } -cleanup { # We used [makeFile] so we undo with [removeFile] removeFile $foofile -} -result {0} +} -match glob -result * # dirname test cmdAH-8.1 {Tcl_FileObjCmd: dirname} -returnCodes error -body { @@ -497,33 +498,36 @@ test cmdAH-9.26 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {//foo/bar} } {} -test cmdAH-9.42 {Tcl_FileObjCmd: tail} testsetplatform { +test cmdAH-9.42 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) +} -body { set env(HOME) "/home/test" testsetplatform unix - set result [file tail ~] + file tail ~ +} -cleanup { set env(HOME) $temp - set result -} test -test cmdAH-9.43 {Tcl_FileObjCmd: tail} testsetplatform { +} -result test +test cmdAH-9.43 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) +} -body { set env(HOME) "~" testsetplatform unix - set result [file tail ~] + file tail ~ +} -cleanup { set env(HOME) $temp - set result -} {} -test cmdAH-9.44 {Tcl_FileObjCmd: tail} testsetplatform { +} -result {} +test cmdAH-9.44 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) +} -body { set env(HOME) "/home/test" testsetplatform windows - set result [file tail ~] + file tail ~ +} -cleanup { set env(HOME) $temp - set result -} test +} -result test test cmdAH-9.46 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail {f.oo\bar/baz.bat} @@ -923,10 +927,10 @@ test cmdAH-19.7 {Tcl_FileObjCmd: nativename} -body { test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 -test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} { - # should probably be 0 in fact... - catch {file nativename ~nOsUcHuSeR} -} 1 +test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} -body { + # should probably be a non-error in fact... + file nativename ~nOsUcHuSeR +} -returnCodes error -match glob -result * # The test below has to be done in /tmp rather than the current directory in # order to guarantee (?) a local file system: some NFS file systems won't do # the stuff below correctly. @@ -963,7 +967,7 @@ test cmdAH-20.1 {Tcl_FileObjCmd: atime} -returnCodes error -body { file atime a b c } -result {wrong # args: should be "file atime name ?time?"} test cmdAH-20.2 {Tcl_FileObjCmd: atime} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat list [expr {[file mtime $gorpfile] == $stat(mtime)}] \ @@ -1031,13 +1035,13 @@ test cmdAH-23.2 {Tcl_FileObjCmd: lstat} -returnCodes error -body { file lstat a b c } -result {wrong # args: should be "file lstat name varName"} test cmdAH-23.3 {Tcl_FileObjCmd: lstat} -setup { - catch {unset stat} + unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat lsort [array names stat] } -result {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-23.4 {Tcl_FileObjCmd: lstat} -setup { - catch {unset stat} + unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat list $stat(nlink) [expr $stat(mode)&0777] $stat(type) @@ -1047,12 +1051,12 @@ test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} -setup { - catch {unset x} + unset -nocomplain x } -body { set x 44 list [catch {file lstat $gorpfile x} msg] $msg $errorCode } -result {1 {can't set "x(dev)": variable isn't array} {TCL LOOKUP VARNAME x}} -catch {unset stat} +unset -nocomplain stat # mkdir set dirA [file join [temporaryDirectory] a] set dirB [file join [temporaryDirectory] a] @@ -1128,7 +1132,7 @@ test cmdAH-24.2 {Tcl_FileObjCmd: mtime} -setup { } } -result {1} test cmdAH-24.3 {Tcl_FileObjCmd: mtime} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat list [expr {[file mtime $gorpfile] == $stat(mtime)}] \ @@ -1294,7 +1298,7 @@ test cmdAH-28.2 {Tcl_FileObjCmd: stat} -returnCodes error -body { file stat _bogus_ a b } -result {wrong # args: should be "file stat name varName"} test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup { - catch {unset stat} + unset -nocomplain stat set stat(blocks) [set stat(blksize) {}] } -body { file stat $gorpfile stat @@ -1302,13 +1306,13 @@ test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup { lsort [array names stat] } -result {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-28.4 {Tcl_FileObjCmd: stat} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat list $stat(nlink) $stat(size) $stat(type) } -result {1 12 file} test cmdAH-28.5 {Tcl_FileObjCmd: stat} -constraints {unix} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat expr {$stat(mode) & 0o777} @@ -1317,7 +1321,7 @@ test cmdAH-28.6 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_ stat} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} test cmdAH-28.7 {Tcl_FileObjCmd: stat} -setup { - catch {unset x} + unset -nocomplain x } -returnCodes error -body { set x 44 file stat $gorpfile x @@ -1371,7 +1375,7 @@ test cmdAH-28.12 {Tcl_FileObjCmd: stat} -setup { } -cleanup { removeFile $filename } -result 1 -catch {unset stat} +unset -nocomplain stat # type test cmdAH-29.1 {Tcl_FileObjCmd: type} -returnCodes error -body { @@ -1513,7 +1517,7 @@ test cmdAH-32.2 {file tempfile - returns a read/write channel} -body { catch {close $f} } -result ok test cmdAH-32.3 {file tempfile - makes filenames} -setup { - catch {unset name} + unset -nocomplain name } -body { set result [info exists name] set f [file tempfile name] @@ -1556,7 +1560,7 @@ interp delete simpleInterp # cleanup catch {testsetplatform $platform} -catch {unset platform} +unset -nocomplain platform # Tcl_ForObjCmd is tested in for.test diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index c7f6e44..78bb329 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.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: cmdMZ.test,v 1.30 2010/04/05 19:44:45 ferrieux Exp $ +# RCS: @(#) $Id: cmdMZ.test,v 1.31 2011/01/01 15:14:43 dkf Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -38,7 +38,7 @@ namespace eval ::tcl::test::cmdMZ { return 1 } customMatch listGlob [namespace which ListGlobMatch] - + # Tcl_PwdObjCmd test cmdMZ-1.1 {Tcl_PwdObjCmd} -returnCodes error -body { @@ -166,35 +166,31 @@ test cmdMZ-return-2.13 {return option handling} -body { test cmdMZ-return-2.14 {return option handling} -body { return -level 0 -code error -options {-code foo -options {-code break}} } -returnCodes break -result {} -test cmdMZ-return-2.15 {return opton handling} -setup { - proc p {} { - return -code error -errorcode {a b} c - } -} -body { - list [catch p result] $result $::errorCode -} -cleanup { - rename p {} -} -result {1 c {a b}} -test cmdMZ-return-2.16 {return opton handling} -setup { - proc p {} { - return -code error -errorcode [list a b] c - } -} -body { - list [catch p result] $result $::errorCode -} -cleanup { - rename p {} -} -result {1 c {a b}} -test cmdMZ-return-2.17 {return opton handling} -setup { - proc p {} { - return -code error -errorcode a\ b c - } -} -body { - list [catch p result] $result $::errorCode -} -cleanup { - rename p {} -} -result {1 c {a b}} +test cmdMZ-return-2.15 {return opton handling} { + list [catch { + apply {{} { + return -code error -errorcode {a b} c + }} + } result] $result $::errorCode +} {1 c {a b}} +test cmdMZ-return-2.16 {return opton handling} { + list [catch { + apply {{} { + return -code error -errorcode [list a b] c + }} + } result] $result $::errorCode +} {1 c {a b}} +test cmdMZ-return-2.17 {return opton handling} { + list [catch { + apply {{} { + return -code error -errorcode a\ b c + }} + } result] $result $::errorCode +} {1 c {a b}} test cmdMZ-return-2.18 {return option handling} { - list [catch {return -code error -errorstack [list CALL a CALL b] yo} -> foo] [dictSort $foo] [info errorstack] + list [catch { + return -code error -errorstack [list CALL a CALL b] yo + } -> foo] [dictSort $foo] [info errorstack] } {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}} # Check that the result of a [return -options $opts $result] is @@ -349,7 +345,7 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { "time {error foo}"}} # The tests for Tcl_WhileObjCmd are in while.test - + # cleanup cleanupTests } diff --git a/tests/compExpr.test b/tests/compExpr.test index c3e68c1..afa3b56 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -1,17 +1,17 @@ -# This file contains a collection of tests for the procedures in the -# file tclCompExpr.c. 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 the procedures in the file +# tclCompExpr.c. 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: compExpr.test,v 1.17 2008/01/16 21:54:33 dgp Exp $ +# RCS: @(#) $Id: compExpr.test,v 1.18 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } @@ -25,7 +25,7 @@ if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1" testConstraint memory [llength [info commands memory]] catch {unset a} - + test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} { expr 1+2 } 3 @@ -35,17 +35,17 @@ test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} -body { test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} -body { list [catch {expr "foo(123)"} msg] $msg } -match glob -result {1 {* "*foo"}} - test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} { set a {0o00123} expr {$a} } 83 -test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} { - catch {unset a} +test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} -setup { + unset -nocomplain a +} -body { set a 27 expr {"foo$a" < "bar"} -} 0 +} -result 0 test compExpr-2.2 {CompileSubExpr procedure, error compiling TCL_TOKEN_WORD parse token} -body { expr {"00[expr 1+]" + 17} } -returnCodes error -match glob -result * @@ -68,30 +68,33 @@ test compExpr-2.7 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} { test compExpr-2.8 {CompileSubExpr procedure, error in TCL_TOKEN_COMMAND parse token} -body { expr {[foo "bar"xxx] + 17} } -returnCodes error -match glob -result * -test compExpr-2.9 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} { - catch {unset a} +test compExpr-2.9 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} -setup { + unset -nocomplain a +} -body { set a 123 expr {$a*2} -} 246 -test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} { - catch {unset a} - catch {unset b} +} -result 246 +test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} -setup { + unset -nocomplain a + unset -nocomplain b +} -body { set a(george) martha set b geo expr {$a(${b}rge)} -} martha -test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} { - catch {unset a} - list [catch {expr {$a + 17}} msg] $msg -} {1 {can't read "a": no such variable}} +} -result martha +test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} -body { + unset -nocomplain a + expr {$a + 17} +} -returnCodes error -result {can't read "a": no such variable} test compExpr-2.12 {CompileSubExpr procedure, TCL_TOKEN_SUB_EXPR parse token} { expr {27||3? 3<<(1+4) : 4&&9} } 96 -test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { - catch {unset a} +test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup { + unset -nocomplain a +} -body { set a 15 list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg -} {0 1} +} -result {0 1} test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} { expr {5*6} } 30 @@ -149,11 +152,12 @@ test compExpr-2.31 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal o test compExpr-2.32 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} { expr {~4} } -5 -test compExpr-2.33 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, comparison} { - catch {unset a} +test compExpr-2.33 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, comparison} -setup { + unset -nocomplain a +} -body { set a 15 expr {$a==15} ;# compiled out-of-line to runtime call on Tcl_ExprObjCmd -} 1 +} -result 1 test compExpr-2.34 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { expr {+2} } 2 @@ -175,72 +179,84 @@ test compExpr-2.39 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special test compExpr-2.40 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { expr {4-2} } 2 -test compExpr-2.41 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { - catch {unset a} +test compExpr-2.41 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup { + unset -nocomplain a +} -body { set a true expr {0||$a} -} 1 -test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { - catch {unset a} +} -result 1 +test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup { + unset -nocomplain a +} -body { set a 15 list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg -} {0 1} -test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { - catch {unset a} +} -result {0 1} +test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup { + unset -nocomplain a +} -body { set a false expr {3&&$a} -} 0 -test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { - catch {unset a} +} -result 0 +test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup { + unset -nocomplain a +} -body { set a false expr {$a||1? 1 : 0} -} 1 -test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { - catch {unset a} +} -result 1 +test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup { + unset -nocomplain a +} -body { set a 15 list [catch {expr {1? 54 : "$a[expr 1+]00"}} msg] $msg -} {0 54} +} -result {0 54} -test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} { - catch {unset a} +test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} -setup { + unset -nocomplain a +} -body { set a 2 expr {[set a]||0} -} 1 -test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} { - catch {unset a} +} -result 1 +test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} -setup { + unset -nocomplain a +} -body { set a no expr {$a&&1} -} 0 +} -result 0 test compExpr-3.3 {CompileSubExpr procedure, error in 1st operand} -body { expr {[expr *2]||0} } -returnCodes error -match glob -result * -test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} { - catch {unset a} - catch {unset b} +test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} -setup { + unset -nocomplain a + unset -nocomplain b +} -body { set a no set b true expr {$a || $b} -} 1 -test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} { - catch {unset a} +} -result 1 +test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} -setup { + unset -nocomplain a +} -body { set a yes expr {$a || [exit]} -} 1 -test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} { - catch {unset a} +} -result 1 +test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} -setup { + unset -nocomplain a +} -body { set a no expr {$a && [exit]} -} 0 -test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} { - catch {unset a} +} -result 0 +test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} -setup { + unset -nocomplain a +} -body { set a 2 expr {0||[set a]} -} 1 -test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} { - catch {unset a} +} -result 1 +test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} -setup { + unset -nocomplain a +} -body { set a no expr {1&&$a} -} 0 +} -result 0 test compExpr-3.9 {CompileLandOrLorExpr procedure, error in 2nd operand} -body { expr {0||[expr %2]} } -returnCodes error -match glob -result * @@ -250,42 +266,48 @@ test compExpr-3.10 {CompileLandOrLorExpr procedure, long lor/land arm} { expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} } 1 -test compExpr-4.1 {CompileCondExpr procedure, simple test} { - catch {unset a} +test compExpr-4.1 {CompileCondExpr procedure, simple test} -setup { + unset -nocomplain a +} -body { set a 2 expr {($a > 1)? "ok" : "nope"} -} ok -test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} { - catch {unset a} +} -result ok +test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} -setup { + unset -nocomplain a +} -body { set a no expr {[set a]? 27 : -54} -} -54 +} -result -54 test compExpr-4.3 {CompileCondExpr procedure, error in test} -body { expr {[expr *2]? +1 : -1} } -returnCodes error -match glob -result * -test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} { - catch {unset a} +test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} -setup { + unset -nocomplain a +} -body { set a no expr {1? (27-2) : -54} -} 25 -test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} { - catch {unset a} +} -result 25 +test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} -setup { + unset -nocomplain a +} -body { set a no expr {1? $a : -54} -} no +} -result no test compExpr-4.6 {CompileCondExpr procedure, error in "true" clause} -body { expr {1? [expr *2] : -127} } -returnCodes error -match glob -result * -test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} { - catch {unset a} +test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} -setup { + unset -nocomplain a +} -body { set a no expr {(2-2)? -3.14159 : "nope"} -} nope -test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} { - catch {unset a} +} -result nope +test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} -setup { + unset -nocomplain a +} -body { set a 0o0123 expr {0? 42 : $a} -} 83 +} -result 83 test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { list [catch {expr {1? 15 : [expr *2]}} msg] $msg } {0 15} @@ -294,8 +316,8 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { format %.6g [expr atan2(1.0, 2.0)] } 0.463648 test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { - list [catch {expr {do_it()}} msg] $msg -} -match glob -result {1 {* "*do_it"}} + expr {do_it()} +} -returnCodes error -match glob -result {* "*do_it"} test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions { expr 3*T1()-1 } 368 @@ -303,8 +325,8 @@ test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathf expr T2()*3 } 1035 test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body { - list [catch {expr {atan2(1.0)}} msg] $msg -} -match glob -result {1 {too few arguments for math function*}} + expr {atan2(1.0)} +} -returnCodes error -match glob -result {too few arguments for math function*} test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] } 9.97424 @@ -312,11 +334,11 @@ test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} -body { expr {sinh(2.*)} } -returnCodes error -match glob -result * test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} -body { - list [catch {expr {sinh(2.0, 3.0)}} msg] $msg -} -match glob -result {1 {too many arguments for math function*}} + expr {sinh(2.0, 3.0)} +} -returnCodes error -match glob -result {too many arguments for math function*} test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} -body { - list [catch {expr {0 <= rand(5.2)}} msg] $msg -} -match glob -result {1 {too many arguments for math function*}} + expr {0 <= rand(5.2)} +} -returnCodes error -match glob -result {too many arguments for math function*} test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} -body { expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3 @@ -360,9 +382,14 @@ test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setu unset end i tmp rename getbytes {} } -result 0 - + # cleanup catch {unset a} catch {unset b} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/compile.test b/tests/compile.test index 4f4c53e..51cf64c 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -1,17 +1,17 @@ -# This file contains tests for the files tclCompile.c, tclCompCmds.c -# and tclLiteral.c +# This file contains tests for the files tclCompile.c, tclCompCmds.c and +# tclLiteral.c # -# 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) 1997 by 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: compile.test,v 1.52 2010/11/03 00:59:22 kennykb Exp $ +# RCS: @(#) $Id: compile.test,v 1.53 2011/01/01 15:14:43 dkf Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -28,10 +28,11 @@ catch {namespace delete test_ns_compile} catch {unset x} catch {unset y} catch {unset a} - -test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} { + +test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} -setup { catch {namespace delete test_ns_compile} catch {unset x} +} -body { set x 123 namespace eval test_ns_compile { proc set {args} { @@ -43,63 +44,70 @@ test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} { } } list [test_ns_compile::p] [set x] -} {{123 test_ns_compile::set} {123 test_ns_compile::set}} +} -result {{123 test_ns_compile::set} {123 test_ns_compile::set}} test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} { proc p {x} {info commands 3m} list [catch {p} msg] $msg } {1 {wrong # args: should be "p x"}} -test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} { + +test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} -setup { catch {unset x} +} -body { set x 123 - list $::x [expr {[lsearch -exact [info globals] x] != 0}] -} {123 1} -test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} { + list $::x [expr {"x" in [info globals]}] +} -result {123 1} +test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} -setup { catch {unset y} +} -body { proc p {} { set ::y 789 return $::y } - list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] -} {789 789 1} -test compile-2.3 {TclCompileDollarVar: global array name with ::s} { + list [p] $::y [expr {"y" in [info globals]}] +} -result {789 789 1} +test compile-2.3 {TclCompileDollarVar: global array name with ::s} -setup { catch {unset a} +} -body { set ::a(1) 2 - list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}] -} {2 3 3 1} -test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} { + list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {"a" in [info globals]}] +} -result {2 3 3 1} +test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} -setup { catch {unset a} +} -body { proc p {} { set ::a(1) 1 return $::a($::a(1)) } - list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] -} {1 1 1} -test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} { + list [p] $::a(1) [expr {"a" in [info globals]}] +} -result {1 1 1} +test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} -setup { catch {unset a} +} -body { proc p {} { global a set a(1) 1 return ${a(1)}$::a(1)$a(1) } - list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] -} {111 1 1} + list [p] $::a(1) [expr {"a" in [info globals]}] +} -result {111 1 1} -test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} { +test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} -setup { catch {unset a} +} -body { set a(1) xyzzyx proc p {} { global a catch {set x 123} a(1) } list [p] $a(1) -} {0 123} +} -result {0 123} test compile-3.2 {TclCompileCatchCmd: non-local variables} { set ::foo 1 proc catch-test {} { catch {set x 3} ::foo } catch-test - set ::foo + return $::foo } 3 test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} { proc catch-test {str} { @@ -107,7 +115,7 @@ test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} { error BAD } catch {catch-test error} ::foo - set ::foo + return $::foo } {GOOD} test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} { proc foo {} { @@ -158,7 +166,6 @@ test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*} -cleanup {namespace delete catchtest} } - test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 set j 0 @@ -187,29 +194,32 @@ test compile-5.2 {TclCompileForeachCmd: non-local variables} { set ::foo } 3 -test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} { +test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup { catch {unset x} catch {unset y} +} -body { set x 123 proc p {} { set ::y 789 return $::y } - list $::x [expr {[lsearch -exact [info globals] x] != 0}] \ - [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] -} {123 1 789 789 1} -test compile-6.2 {TclCompileSetCmd: global array names with ::s} { + list $::x [expr {"x" in [info globals]}] \ + [p] $::y [expr {"y" in [info globals]}] +} -result {123 1 789 789 1} +test compile-6.2 {TclCompileSetCmd: global array names with ::s} -setup { catch {unset a} +} -body { set ::a(1) 2 proc p {} { set ::a(1) 1 return $::a($::a(1)) } - list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] -} {2 1 3 3 1} -test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} { + list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {"a" in [info globals]}] +} -result {2 1 3 3 1} +test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} -setup { catch {namespace delete test_ns_compile} catch {unset x} +} -body { namespace eval test_ns_compile { variable v hello variable arr @@ -217,7 +227,7 @@ test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} { set ::test_ns_compile::arr(1) 123 } list $::x $::test_ns_compile::arr(1) -} {hello 123} +} -result {hello 123} test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { set i 0 @@ -258,53 +268,45 @@ test compile-10.1 {BLACKBOX: exception stack overflow} { } } {} -test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { +test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { # shared object - Interp result && Var 'r' set r [list foobar] # command that will add error to result lindex a bogus - } - list [catch {p} msg] $msg -} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} -test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; string index a bogus } - list [catch {p} msg] $msg -} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} + }} +} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} +test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; string index a bogus }} +} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - proc p {} { set r [list foobar] ; string index a 0o9 } - list [catch {p} msg] $msg -} -match glob -result {1 {*invalid octal number*}} -test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; array set var {one two many} } - list [catch {p} msg] $msg -} {1 {list must have an even number of elements}} -test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; incr foo bar baz} - list [catch {p} msg] $msg -} {1 {wrong # args: should be "incr varName ?increment?"}} -test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; incr} - list [catch {p} msg] $msg -} {1 {wrong # args: should be "incr varName ?increment?"}} + apply {{} { set r [list foobar] ; string index a 0o9 }} +} -returnCodes error -match glob -result {*invalid octal number*} +test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; array set var {one two many} }} +} -returnCodes error -result {list must have an even number of elements} +test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; incr foo bar baz}} +} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} +test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; incr}} +} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - proc p {} { set r [list foobar] ; expr !a } - p + apply {{} { set r [list foobar] ; expr !a }} } -returnCodes error -match glob -result * test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - proc p {} { set r [list foobar] ; expr {!a} } - p + apply {{} { set r [list foobar] ; expr {!a} }} } -returnCodes error -match glob -result * -test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; llength "\{" } +test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; llength "\{" }} list [catch {p} msg] $msg -} {1 {unmatched open brace in list}} +} -returnCodes error -result {unmatched open brace in list} # # Special section for tests of tclLiteral.c # The following tests check for incorrect memory handling in -# TclReleaseLiteral. They are only effective when tcl is compiled -# with TCL_MEM_DEBUG +# TclReleaseLiteral. They are only effective when tcl is compiled with +# TCL_MEM_DEBUG # # Special test for leak on interp delete [Bug 467523]. test compile-12.1 {testing literal leak on interp delete} -setup { @@ -328,9 +330,9 @@ test compile-12.1 {testing literal leak on interp delete} -setup { rename getbytes {} unset -nocomplain end i tmp leakedBytes } -result 0 -# Special test for a memory error in a preliminary fix of [Bug 467523]. -# It requires executing a helpfile. Presumably the child process is -# used because when this test fails, it crashes. +# Special test for a memory error in a preliminary fix of [Bug 467523]. It +# requires executing a helpfile. Presumably the child process is used because +# when this test fails, it crashes. test compile-12.2 {testing error on literal deletion} -constraints {memory exec} -body { set sourceFile [makeFile { for {set i 0} {$i < 5} {incr i} { @@ -355,29 +357,28 @@ test compile-12.3 {check for a buffer overrun} -body { test compile-12.4 {TclCleanupLiteralTable segfault} -body { # Tcl Bug 1001997 # Here, we're trying to test a case that causes a crash in - # TclCleanupLiteralTable. The conditions that we're trying to - # establish are: - # - TclCleanupLiteralTable is attempting to clean up a bytecode - # object in the literal table. - # - The bytecode object in question contains the only reference - # to another literal. + # TclCleanupLiteralTable. The conditions that we're trying to establish + # are: + # - TclCleanupLiteralTable is attempting to clean up a bytecode object in + # the literal table. + # - The bytecode object in question contains the only reference to another + # literal. # - The literal in question is in the same hash bucket as the bytecode # object, and immediately follows it in the chain. - # Since newly registered literals are added at the FRONT of the - # bucket chains, and since the bytecode object is registered before - # its literals, this is difficult to achieve. What we do is: - # (a) do a [namespace eval] of a string that's calculated to - # hash into the same bucket as a literal that it contains. - # In this case, the script and the variable 'bugbug' - # land in the same bucket. - # (b) do a [namespace eval] of a string that contains enough - # literals to force TclRegisterLiteral to rebuild the global - # literal table. The newly created hash buckets will contain - # the literals, IN REVERSE ORDER, thus putting the bytecode - # immediately ahead of 'bugbug' and 'bug4345bug'. The bytecode - # object will contain the only references to those two literals. - # (c) Delete the interpreter to invoke TclCleanupLiteralTable - # and tickle the bug. + # Since newly registered literals are added at the FRONT of the bucket + # chains, and since the bytecode object is registered before its literals, + # this is difficult to achieve. What we do is: + # (a) do a [namespace eval] of a string that's calculated to hash into + # the same bucket as a literal that it contains. In this case, the + # script and the variable 'bugbug' land in the same bucket. + # (b) do a [namespace eval] of a string that contains enough literals to + # force TclRegisterLiteral to rebuild the global literal table. The + # newly created hash buckets will contain the literals, IN REVERSE + # ORDER, thus putting the bytecode immediately ahead of 'bugbug' and + # 'bug4345bug'. The bytecode object will contain the only references + # to those two literals. + # (c) Delete the interpreter to invoke TclCleanupLiteralTable and tickle + # the bug. proc foo {} { set i [interp create] $i eval { @@ -411,9 +412,8 @@ test compile-12.4 {TclCleanupLiteralTable segfault} -body { rename foo {} } -result ok -# Special test for underestimating the maxStackSize required for a -# compiled command. A failure will cause a segfault in the child -# process. +# Special test for underestimating the maxStackSize required for a compiled +# command. A failure will cause a segfault in the child process. test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} { set body {set x [list} for {set i 0} {$i < 3000} {incr i} { @@ -424,8 +424,8 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} { list [catch {exec [interpreter] << $script} msg] $msg } {0 OK} -# Special test for compiling tokens from a copy of the source -# string [Bug #599788] +# Special test for compiling tokens from a copy of the source string. [Bug +# 599788] test compile-14.1 {testing errors in element name; segfault?} {} { catch {set a([error])} msg1 catch {set bubba([join $abba $jubba]) $vol} msg2 @@ -434,34 +434,19 @@ test compile-14.1 {testing errors in element name; segfault?} {} { # Tests compile-15.* cover Tcl Bug 633204 test compile-15.1 {proper TCL_RETURN code from [return]} { - proc p {} {catch return} - set result [p] - rename p {} - set result + apply {{} {catch return}} } 2 test compile-15.2 {proper TCL_RETURN code from [return]} { - proc p {} {catch {return foo}} - set result [p] - rename p {} - set result + apply {{} {catch {return foo}}} } 2 test compile-15.3 {proper TCL_RETURN code from [return]} { - proc p {} {catch {return $::tcl_library}} - set result [p] - rename p {} - set result + apply {{} {catch {return $::tcl_library}}} } 2 test compile-15.4 {proper TCL_RETURN code from [return]} { - proc p {} {catch {return [info library]}} - set result [p] - rename p {} - set result + apply {{} {catch {return [info library]}}} } 2 test compile-15.5 {proper TCL_RETURN code from [return]} { - proc p {} {catch {set a 1}; return} - set result [p] - rename p {} - set result + apply {{} {catch {set a 1}; return}} } "" for {set noComp 0} {$noComp <= 1} {incr noComp} { @@ -536,17 +521,16 @@ test compile-16.17.$noComp {TclCompileScript: word expansion} $constraints { run {list {*}x y z} } {x y z} -# These tests note that expansion can in theory cause the number of -# arguments to a command to exceed INT_MAX, which is as big as objc -# is allowed to get. +# These tests note that expansion can in theory cause the number of arguments +# to a command to exceed INT_MAX, which is as big as objc is allowed to get. # -# In practice, it seems we will run out of memory before we confront -# this issue. Note that compiled operations run out of memory at -# smaller objc values than direct string evaluation. +# In practice, it seems we will run out of memory before we confront this +# issue. Note that compiled operations run out of memory at smaller objc +# values than direct string evaluation. # -# These tests are constrained as knownBug because they are likely -# to cause memory allocation panics somewhere, and we don't want -# panics in the test suite. +# These tests are constrained as knownBug because they are likely to cause +# memory allocation panics somewhere, and we don't want panics in the test +# suite. # test compile-16.18.$noComp {TclCompileScript: word expansion} -body { proc LongList {} {return [lrepeat [expr {1<<10}] x]} @@ -608,8 +592,8 @@ test compile-16.26.$noComp {TclCompileScript: word expansion, protected backslas } {a {\n} b} } ;# End of noComp loop -# These tests are messy because it wrecks the interpreter it runs in! -# They demonstrate issues arising from [FRQ 1101710] +# These tests are messy because it wrecks the interpreter it runs in! They +# demonstrate issues arising from [FRQ 1101710] test compile-17.1 {Command interpretation binding for compiled code} -constraints knownBug -setup { set i [interp create] } -body { @@ -723,7 +707,7 @@ test compile-18.19 {disassembler - basics} -setup { foo destroy } -match glob -result * # TODO sometime - check that bytecode from tbcload is *not* disassembled. - + # cleanup catch {rename p ""} catch {namespace delete test_ns_compile} @@ -732,3 +716,8 @@ catch {unset y} catch {unset a} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/concat.test b/tests/concat.test index c369340..8988bb0 100644 --- a/tests/concat.test +++ b/tests/concat.test @@ -1,23 +1,23 @@ # Commands covered: concat # -# 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-1996 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: concat.test,v 1.6 2004/05/19 10:55:05 dkf Exp $ +# RCS: @(#) $Id: concat.test,v 1.7 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - + test concat-1.1 {simple concatenation} { concat a b c d e f g } {a b c d e f g} @@ -48,7 +48,12 @@ test concat-4.2 {pruning off extra white space} { test concat-4.3 {pruning off extra white space sets length correctly} { llength [concat { {{a}} }] } 1 - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/eval.test b/tests/eval.test index 98acd08..5d2813f 100644 --- a/tests/eval.test +++ b/tests/eval.test @@ -1,23 +1,23 @@ # Commands covered: eval # -# 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: eval.test,v 1.9 2006/10/09 19:15:44 msofer Exp $ +# RCS: @(#) $Id: eval.test,v 1.10 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - + test eval-1.1 {single argument} { eval {format 22} } 22 @@ -80,7 +80,12 @@ test eval-3.4 {concatenating eval and canonical lists} { unset dummy eval $cmd $cmd2 } {1 2 3 4 5} - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/fileName.test b/tests/fileName.test index d46391a..c7c591d 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -10,9 +10,9 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fileName.test,v 1.66 2010/01/05 18:58:36 dgp Exp $ +# RCS: @(#) $Id: fileName.test,v 1.67 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -42,7 +42,7 @@ global env if {[testConstraint testsetplatform]} { set platform [testgetplatform] } - + # Caution: when using 'testsetplatform' to test different file name platform # descriptions in this file, one must be very careful not to combine such # platform manipulation with commands like 'cd', 'pwd'. That is because the @@ -1434,7 +1434,7 @@ test filename-16.13 {windows specific globbing} {win sharedCdrive} { } //[info hostname]/c/globTest test filename-16.14 {windows specific globbing} {win} { cd [lindex [glob -types d -dir C:/ *] 0] - expr {[lsearch -exact [glob {{.,*}*}] ".."] != -1} + expr {".." in [glob {{.,*}*}]} } {1} test filename-16.15 {windows specific globbing} {win} { cd [lindex [glob -types d -dir C:/ *] 0] @@ -1529,7 +1529,6 @@ test fileName-20.4 {Bug 1750300} -setup { removeFile TAGS $d removeDirectory foo } -result 0 - test fileName-20.5 {Bug 2837800} -setup { set dd [makeDirectory isolate] set d [makeDirectory ./~foo $dd] @@ -1544,7 +1543,6 @@ test fileName-20.5 {Bug 2837800} -setup { removeDirectory ./~foo $dd removeDirectory isolate } -result ~foo/test - test fileName-20.6 {Bug 2837800} -setup { # Recall that we have $env(HOME) set so that references # to ~ point to [temporaryDirectory] @@ -1561,7 +1559,6 @@ test fileName-20.6 {Bug 2837800} -setup { removeDirectory isolate removeFile test ~ } -result {} - test fileName-20.7 {Bug 2806250} -setup { set savewd [pwd] cd [temporaryDirectory] @@ -1574,7 +1571,6 @@ test fileName-20.7 {Bug 2806250} -setup { removeDirectory isolate cd $savewd } -result 1 - test fileName-20.8 {Bug 2806250} -setup { set savewd [pwd] cd [temporaryDirectory] @@ -1587,8 +1583,7 @@ test fileName-20.8 {Bug 2806250} -setup { removeDirectory isolate cd $savewd } -result ./~test - -test fileName-20.9 {} -setup { +test fileName-20.9 {globbing for special chars} -setup { makeFile {} test ~ set d [makeDirectory isolate] set savewd [pwd] @@ -1600,8 +1595,7 @@ test fileName-20.9 {} -setup { removeDirectory isolate removeFile test ~ } -result ~/test - -test fileName-20.10 {} -setup { +test fileName-20.10 {globbing for special chars} -setup { set s [makeDirectory sub ~] makeFile {} fileName-20.10 $s set d [makeDirectory isolate] @@ -1615,7 +1609,7 @@ test fileName-20.10 {} -setup { removeFile fileName-20.10 $s removeDirectory sub ~ } -result ~/sub/fileName-20.10 - + # cleanup catch {file delete -force C:/globTest} cd [temporaryDirectory] diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 1691eb5..6ab554b 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -36,7 +36,7 @@ if {[testConstraint win]} { set vols [string map [list :/ {}] [file volumes]] for {set i 0} {$i < 26} {incr i} { set drive [format %c [expr {$i + 65}]] - if {[lsearch -exact $vols $drive] == -1} { + if {$drive ni $vols} { testConstraint unusedDrive 1 break } diff --git a/tests/interp.test b/tests/interp.test index 6df8f31e..c67dcf7 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -10,9 +10,9 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: interp.test,v 1.70 2010/12/09 15:09:08 dkf Exp $ +# RCS: @(#) $Id: interp.test,v 1.71 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -147,7 +147,7 @@ test interp-3.8 {testing interp exists and interp slaves} -body { } -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} test interp-3.9 {testing interp exists and interp slaves} { interp create {a a2} -safe - expr {[lsearch [interp slaves a] a2] >= 0} + expr {"a2" in [interp slaves a]} } 1 test interp-3.10 {testing interp exists and interp slaves} { interp exists {a a2} @@ -174,7 +174,7 @@ test interp-4.5 {testing interp delete} { interp create a interp create {a x1} interp delete {a x1} - expr {[lsearch [interp slaves a] x1] >= 0} + expr {"x1" in [interp slaves a]} } 0 test interp-4.6 {testing interp delete} { interp create c1 diff --git a/tests/lsearch.test b/tests/lsearch.test index 634adda..fd58978 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -1,23 +1,23 @@ # Commands covered: lsearch # -# 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: lsearch.test,v 1.22 2008/09/29 12:25:21 dkf Exp $ +# RCS: @(#) $Id: lsearch.test,v 1.23 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } - + set x {abcd bbcd 123 234 345} test lsearch-1.1 {lsearch command} { lsearch $x 123 @@ -47,9 +47,9 @@ test lsearch-2.4 {search modes} { test lsearch-2.5 {search modes} { lsearch -exact {foo bar cat} bar } 1 -test lsearch-2.6 {search modes} { - list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg -} {1 {couldn't compile regular expression pattern: quantifier operand invalid}} +test lsearch-2.6 {search modes} -returnCodes error -body { + lsearch -regexp {xyz bbcc *bc*} *bc* +} -result {couldn't compile regular expression pattern: quantifier operand invalid} test lsearch-2.7 {search modes} { lsearch -regexp {b.x ^bc xy bcx} ^bc } 3 @@ -59,9 +59,9 @@ test lsearch-2.8 {search modes} { test lsearch-2.9 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 -test lsearch-2.10 {search modes} { - list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg -} {1 {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} +test lsearch-2.10 {search modes} -returnCodes error -body { + lsearch -glib {b.x bx xy bcx} b.x +} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} test lsearch-2.11 {search modes with -nocase} { lsearch -exact -nocase {a b c A B C} A } 0 @@ -81,27 +81,27 @@ test lsearch-2.16 {search modes without -nocase} { lsearch -regexp {a b c A B C} ^A\$ } 3 -test lsearch-3.1 {lsearch errors} { - list [catch lsearch msg] $msg -} {1 {wrong # args: should be "lsearch ?-option value ...? list pattern"}} -test lsearch-3.2 {lsearch errors} { - list [catch {lsearch a} msg] $msg -} {1 {wrong # args: should be "lsearch ?-option value ...? list pattern"}} -test lsearch-3.3 {lsearch errors} { - list [catch {lsearch a b c} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} -test lsearch-3.4 {lsearch errors} { - list [catch {lsearch a b c d} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} -test lsearch-3.5 {lsearch errors} { - list [catch {lsearch "\{" b} msg] $msg -} {1 {unmatched open brace in list}} -test lsearch-3.6 {lsearch errors} { - list [catch {lsearch -index a b} msg] $msg -} {1 {"-index" option must be followed by list index}} -test lsearch-3.7 {lsearch errors} { - list [catch {lsearch -subindices -exact a b} msg] $msg -} {1 {-subindices cannot be used without -index option}} +test lsearch-3.1 {lsearch errors} -returnCodes error -body { + lsearch +} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} +test lsearch-3.2 {lsearch errors} -returnCodes error -body { + lsearch a +} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} +test lsearch-3.3 {lsearch errors} -returnCodes error -body { + lsearch a b c +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +test lsearch-3.4 {lsearch errors} -returnCodes error -body { + lsearch a b c d +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +test lsearch-3.5 {lsearch errors} -returnCodes error -body { + lsearch "\{" b +} -result {unmatched open brace in list} +test lsearch-3.6 {lsearch errors} -returnCodes error -body { + lsearch -index a b +} -result {"-index" option must be followed by list index} +test lsearch-3.7 {lsearch errors} -returnCodes error -body { + lsearch -subindices -exact a b +} -result {-subindices cannot be used without -index option} test lsearch-4.1 {binary data} { lsearch -exact [list foo one\000two bar] bar @@ -300,12 +300,12 @@ test lsearch-10.2 {offset searching} { test lsearch-10.3 {offset searching} { lsearch -start end-4 {a b c a b c} a } 3 -test lsearch-10.4 {offset searching} { - list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg -} {1 {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?}} -test lsearch-10.5 {offset searching} { - list [catch {lsearch -start 1 2} msg] $msg -} {1 {missing starting index}} +test lsearch-10.4 {offset searching} -returnCodes error -body { + lsearch -start foobar {a b c a b c} a +} -result {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?} +test lsearch-10.5 {offset searching} -returnCodes error -body { + lsearch -start 1 2 +} -result {missing starting index} test lsearch-10.6 {binary search with offset} { set res {} for {set i 0} {$i < 100} {incr i} { @@ -453,15 +453,15 @@ test lsearch-19.5 {lsearch -sunindices option} { lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {{0 0 0} {1 0 0}} -test lsearch-20.1 {lsearch -index option, index larger than sublists} { - list [catch {lsearch -index 2 {{a c} {a b} {a a}} a} msg] $msg -} {1 {element 2 missing from sublist "a c"}} -test lsearch-20.2 {lsearch -index option, malformed index} { - list [catch {lsearch -index foo {{a c} {a b} {a a}} a} msg] $msg -} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}} -test lsearch-20.3 {lsearch -index option, malformed index} { - list [catch {lsearch -index \{ {{a c} {a b} {a a}} a} msg] $msg -} {1 {unmatched open brace in list}} +test lsearch-20.1 {lsearch -index option, index larger than sublists} -body { + lsearch -index 2 {{a c} {a b} {a a}} a +} -returnCodes error -result {element 2 missing from sublist "a c"} +test lsearch-20.2 {lsearch -index option, malformed index} -body { + lsearch -index foo {{a c} {a b} {a a}} a +} -returnCodes error -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} +test lsearch-20.3 {lsearch -index option, malformed index} -body { + lsearch -index \{ {{a c} {a b} {a a}} a +} -returnCodes error -result {unmatched open brace in list} test lsearch-21.1 {lsearch shimmering crash} { set x 0 @@ -511,7 +511,7 @@ test lsearch-22.5 {lsearch -bisect, all equal} { test lsearch-22.6 {lsearch -sorted, all equal} { lsearch -sorted -integer {5 5 5 5} 5 } {0} - + # cleanup catch {unset res} catch {unset increasingIntegers} diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 804c233..f4d4598 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -14,9 +14,9 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace-old.test,v 1.14 2008/12/17 15:39:55 dkf Exp $ +# RCS: @(#) $Id: namespace-old.test,v 1.15 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -496,8 +496,8 @@ test namespace-old-7.1 {define test namespace} { } } {} test namespace-old-7.2 {uplevel can access namespace call frame} { - list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] x]>=0}] \ - [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] y]>=0}] + list [expr {"x" in [test_ns_uplevel::test_uplevel 1]}] \ + [expr {"y" in [test_ns_uplevel::test_uplevel 1]}] } {1 1} test namespace-old-7.3 {uplevel can go beyond namespace call frame} { lsort [test_ns_uplevel::test_uplevel 2] @@ -506,8 +506,8 @@ test namespace-old-7.4 {uplevel can go up to global context} { expr {[test_ns_uplevel::test_uplevel 3] == [info globals]} } {1} test namespace-old-7.5 {absolute call frame references work too} { - list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] x]>=0}] \ - [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] y]>=0}] + list [expr {"x" in [test_ns_uplevel::test_uplevel #2]}] \ + [expr {"y" in [test_ns_uplevel::test_uplevel #2]}] } {1 1} test namespace-old-7.6 {absolute call frame references work too} { lsort [test_ns_uplevel::test_uplevel #1] diff --git a/tests/namespace.test b/tests/namespace.test index c1aef53..1c39b5c 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1,23 +1,21 @@ # Functionality covered: this file contains a collection of tests for the -# procedures in tclNamesp.c that implement Tcl's basic support for -# namespaces. Other namespace-related tests appear in variable.test. +# procedures in tclNamesp.c and tclEnsemble.c that implement Tcl's basic +# support for namespaces. Other namespace-related tests appear in +# variable.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-2000 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: namespace.test,v 1.78 2010/01/10 16:51:25 dkf Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +# RCS: @(#) $Id: namespace.test,v 1.79 2011/01/01 15:14:43 dkf Exp $ +package require tcltest 2 +namespace import -force ::tcltest::* testConstraint memory [llength [info commands memory]] # @@ -27,7 +25,7 @@ testConstraint memory [llength [info commands memory]] # Clear out any namespaces called test_ns_* catch {namespace delete {*}[namespace children :: test_ns_*]} - + test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} { namespace children :: test_ns_* } {} @@ -47,7 +45,6 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} { } } lappend l [namespace current] - set l } {:: ::test_ns_1 ::test_ns_1::foo ::} test namespace-3.1 {Tcl_GetGlobalNamespace} { @@ -594,9 +591,8 @@ test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up onl namespace eval bar {} } namespace eval test_ns_1 { - set l [list [catch {namespace delete test_ns_2::bar} msg] $msg] + list [catch {namespace delete test_ns_2::bar} msg] $msg } - set l } {1 {unknown namespace "test_ns_2::bar" in namespace delete command}} test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { @@ -815,7 +811,7 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} { set a 0 namespace eval test_ns_1 set a 1 namespace delete test_ns_1 - set a + return $a } 1 catch {unset a} catch {unset x} @@ -837,7 +833,6 @@ test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadow proc foo {} {return "foo in test_ns_1"} } lappend l [test_ns_1::trigger] - set l } {{global foo} {foo in test_ns_1}} test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} { namespace eval test_ns_2 { @@ -858,7 +853,6 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado } } lappend l [test_ns_1::trigger] - set l } {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}} catch {unset l} catch {rename foo {}} @@ -890,7 +884,6 @@ test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { namespace delete test_ns_1::test_ns_2 namespace eval test_ns_1::test_ns_2::test_ns_3 {} lappend l [test_ns_1::foo] - set l } {{} ::test_ns_1::test_ns_2::test_ns_3} test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { @@ -1420,16 +1413,17 @@ test namespace-39.3 {NamespaceExistsCmd error} { list [catch {namespace exists a b} msg] $msg } {1 {wrong # args: should be "namespace exists name"}} -test namespace-40.1 {Ignoring namespace proc "unknown"} { +test namespace-40.1 {Ignoring namespace proc "unknown"} -setup { rename unknown _unknown +} -body { proc unknown args {return global} namespace eval ns {proc unknown args {return local}} - set l [list [namespace eval ns aaa bbb] [namespace eval ns aaa]] + list [namespace eval ns aaa bbb] [namespace eval ns aaa] +} -cleanup { rename unknown {} rename _unknown unknown namespace delete ns - set l -} {global global} +} -result {global global} test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { set res {} @@ -1447,7 +1441,6 @@ test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { namespace delete ns set res } {0 1} - test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} { set res {} namespace eval ns {} @@ -1461,19 +1454,16 @@ test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} { namespace delete ns set res } {New proc is called} - test namespace-41.3 {Shadowing byte-compiled commands, Bugs: 231259, 729692} { set res {} namespace eval ns { variable b 0 } - proc ns::a {i} { variable b proc set args {return "New proc is called"} return [set b $i] } - set res [list [ns::a 1] $ns::b] namespace delete ns set res @@ -1512,18 +1502,18 @@ test namespace-42.3 {ensembles: basic} { namespace delete ns lappend result [info command ns::x1] } {1 2 1 {unknown or ambiguous subcommand "x": must be x1, or x2} ::ns::x1 {}} -test namespace-42.4 {ensembles: basic} { +test namespace-42.4 {ensembles: basic} -body { namespace eval ns { namespace export y* proc x1 {} {format 1} proc x2 {} {format 2} namespace ensemble create } - set result [list [catch {ns x} msg] $msg] + list [catch {ns x} msg] $msg +} -cleanup { namespace delete ns - set result -} {1 {unknown subcommand "x": namespace ::ns does not export any commands}} -test namespace-42.5 {ensembles: basic} { +} -result {1 {unknown subcommand "x": namespace ::ns does not export any commands}} +test namespace-42.5 {ensembles: basic} -body { namespace eval ns { namespace export x* proc x1 {} {format 1} @@ -1531,11 +1521,11 @@ test namespace-42.5 {ensembles: basic} { proc x3 {} {format 3} namespace ensemble create } - set result [list [catch {ns x} msg] $msg] + list [catch {ns x} msg] $msg +} -cleanup { namespace delete ns - set result -} {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}} -test namespace-42.6 {ensembles: nested} { +} -result {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}} +test namespace-42.6 {ensembles: nested} -body { namespace eval ns { namespace export x* namespace eval x0 { @@ -1548,11 +1538,11 @@ test namespace-42.6 {ensembles: nested} { proc x3 {} {format 3} namespace ensemble create } - set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]] + list [ns x0 z] [ns x1] [ns x2] [ns x3] +} -cleanup { namespace delete ns - set result -} {0 1 2 3} -test namespace-42.7 {ensembles: nested} { +} -result {0 1 2 3} +test namespace-42.7 {ensembles: nested} -body { namespace eval ns { namespace export x* namespace eval x0 { @@ -1565,10 +1555,10 @@ test namespace-42.7 {ensembles: nested} { proc x3 {} {format 3} namespace ensemble create } - set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]] + list [ns x0 z] [ns x1] [ns x2] [ns x3] +} -cleanup { namespace delete ns - set result -} {{1 ::ns::x0::z} 1 2 3} +} -result {{1 ::ns::x0::z} 1 2 3} test namespace-42.8 {ensembles: [Bug 1670091]} -setup { proc demo args {} variable target [list [namespace which demo] x] @@ -1595,7 +1585,7 @@ test namespace-43.1 {ensembles: dict-driven} { rename ns {} lappend result [namespace ensemble exists ns] } {1 {unknown or ambiguous subcommand "c": must be a, or b} 1 0} -test namespace-43.2 {ensembles: dict-driven} { +test namespace-43.2 {ensembles: dict-driven} -body { namespace eval ns { namespace export x* proc x1 {args} {list 1 $args} @@ -1604,10 +1594,10 @@ test namespace-43.2 {ensembles: dict-driven} { a ::ns::x1 b ::ns::x2 c {::ns::x1 .} d {::ns::x2 .} } } - set result [list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo]] + list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo] +} -cleanup { namespace delete ns - set result -} {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}} +} -result {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}} set SETUP { namespace eval ns { namespace export a b @@ -2914,7 +2904,7 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ rename getbytes {} unset i ns start end } -result 0 - + # cleanup catch {rename cmd1 {}} catch {unset l} diff --git a/tests/oo.test b/tests/oo.test index bea9e1a..fbeecc6 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,11 +7,11 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: oo.test,v 1.42 2010/11/18 10:10:14 dkf Exp $ +# RCS: @(#) $Id: oo.test,v 1.43 2011/01/01 15:14:43 dkf Exp $ package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +package require tcltest 2 +if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } diff --git a/tests/proc.test b/tests/proc.test index 789c671..ba0c20d 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -1,40 +1,36 @@ -# This file contains tests for the tclProc.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 includes only new tests, in particular -# tests for code changed for the addition of Tcl namespaces. Other -# procedure-related tests appear in other test files such as proc-old.test. +# This file contains tests for the tclProc.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 includes only new tests, in particular tests for code +# changed for the addition of Tcl namespaces. Other procedure-related tests +# appear in other test files such as proc-old.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: proc.test,v 1.21 2009/10/29 17:21:48 dgp Exp $ +# RCS: @(#) $Id: proc.test,v 1.22 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } -if {[catch {package require procbodytest}]} { - testConstraint procbodytest 0 -} else { - testConstraint procbodytest 1 -} - -testConstraint memory [llength [info commands memory]] +testConstraint procbodytest [expr {![catch {package require procbodytest}]}] +testConstraint memory [llength [info commands memory]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} catch {unset msg} - -test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} { + +test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace eval baz {} } @@ -44,23 +40,26 @@ test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} list [test_ns_1::baz::p] \ [namespace eval test_ns_1 {baz::p}] \ [info commands test_ns_1::baz::*] -} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p} -test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} { +} -result {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p} +test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - list [catch {proc test_ns_1::baz::p {} {}} msg] $msg -} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}} -test proc-1.3 {Tcl_ProcObjCmd, empty proc name} { +} -returnCodes error -body { + proc test_ns_1::baz::p {} {} +} -result {can't create procedure "test_ns_1::baz::p": unknown namespace} +test proc-1.3 {Tcl_ProcObjCmd, empty proc name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { proc :: {} { return "empty called" } list [::] \ [info body {}] -} {{empty called} { +} -result {{empty called} { return "empty called" }} -test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} { +test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace eval baz { proc p {} { @@ -70,9 +69,10 @@ test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} { } list [test_ns_1::baz::p] \ [info commands test_ns_1::baz::*] -} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p} -test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} { +} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p} +test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::baz {} namespace eval test_ns_1 { proc baz::p {} { @@ -82,9 +82,10 @@ test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace list [test_ns_1::baz::p] \ [info commands test_ns_1::baz::*] \ [namespace eval test_ns_1::baz {namespace which p}] -} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p} -test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} { +} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p} +test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc q: {} {return "q:"} proc value:at: {} {return "value:at:"} @@ -96,88 +97,97 @@ test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or e [lsort [info commands test_ns_1::*]] \ [namespace eval test_ns_1 {namespace which q:}] \ [namespace eval test_ns_1 {namespace which value:at:}] -} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:} -test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} { +} -result {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:} +test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup { catch {rename p ""} - list [catch {proc p {a(1) a(2)} { - set z [expr $a(1)+$a(2)] - puts "$z=z, $a(1)=$a(1)" - }} msg] $msg -} {1 {formal parameter "a(1)" is an array element}} -test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} { +} -returnCodes error -body { + proc p {a(1) a(2)} { + set z [expr $a(1)+$a(2)] + puts "$z=z, $a(1)=$a(1)" + } +} -result {formal parameter "a(1)" is an array element} +test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup { catch {rename p ""} - list [catch {proc p {b:a b::a} { - }} msg] $msg -} {1 {formal parameter "b::a" is not a simple name}} +} -body { + proc p {b:a b::a} { + } +} -returnCodes error -result {formal parameter "b::a" is not a simple name} -test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} { +test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { proc p {} {return "p in [namespace current]"} info body p -} {return "p in [namespace current]"} -test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} { +} -result {return "p in [namespace current]"} +test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace eval baz { proc p {} {return "p in [namespace current]"} } } namespace eval test_ns_1::baz {info body p} -} {return "p in [namespace current]"} -test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} { +} -result {return "p in [namespace current]"} +test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::baz {} namespace eval test_ns_1 { proc baz::p {} {return "p in [namespace current]"} } namespace eval test_ns_1 {info body baz::p} -} {return "p in [namespace current]"} -test proc-2.4 {TclFindProc, global proc and executing in namespace} { +} -result {return "p in [namespace current]"} +test proc-2.4 {TclFindProc, global proc and executing in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { proc p {} {return "global p"} namespace eval test_ns_1::baz {info body p} -} {return "global p"} +} -result {return "global p"} -test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} { +test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { proc p {} {return "p in [namespace current]"} p -} {p in ::} -test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} { +} -result {p in ::} +test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::baz { proc p {} {return "p in [namespace current]"} p } -} {p in ::test_ns_1::baz} -test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} { +} -result {p in ::test_ns_1::baz} +test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { proc p {} {return "p in [namespace current]"} namespace eval test_ns_1::baz { p } -} {p in ::} -test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} { +} -result {p in ::} +test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { namespace eval test_ns_1::baz { proc p {} {return "p in [namespace current]"} rename ::test_ns_1::baz::p ::p list [p] [namespace which p] } -} {{p in ::} ::p} -test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} { +} -result {{p in ::} ::p} +test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} -body { proc p {x} {info commands 3m} - list [catch {p} msg] $msg -} {1 {wrong # args: should be "p x"}} - -test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} { + p +} -returnCodes error -result {wrong # args: should be "p x"} +test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} -body { proc {a b c} {x} {info commands 3m} - list [catch {{a b c}} msg] $msg -} {1 {wrong # args: should be "{a b c} x"}} + {a b c} +} -returnCodes error -result {wrong # args: should be "{a b c} x"} catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} @@ -189,116 +199,95 @@ catch {rename p ""} catch {rename t ""} # Note that the test require that procedures whose body is used to create -# procbody objects must be executed before the procbodytest::proc command -# is executed, so that the Proc struct is populated correctly (CompiledLocals -# are added at compile time). +# procbody objects must be executed before the procbodytest::proc command is +# executed, so that the Proc struct is populated correctly (CompiledLocals are +# added at compile time). -test proc-4.1 {TclCreateProc, procbody obj} procbodytest { - catch { - proc p x {return "$x:$x"} - set rv [p P] - procbodytest::proc t x p - lappend rv [t T] - set rv - } result +test proc-4.1 {TclCreateProc, procbody obj} -constraints procbodytest -body { + proc p x {return "$x:$x"} + set rv [p P] + procbodytest::proc t x p + lappend rv [t T] +} -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {P:P T:T} -test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} procbodytest { - catch { - proc p x { - set y [string tolower $x] - return "$x:$y" - } - set rv [p P] - procbodytest::proc t x p - lappend rv [t T] - set rv - } result +} -result {P:P T:T} +test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} -body { + proc p x { + set y [string tolower $x] + return "$x:$y" + } + set rv [p P] + procbodytest::proc t x p + lappend rv [t T] +} -constraints procbodytest -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {P:p T:t} -test proc-4.3 {TclCreateProc, procbody obj, too many args} procbodytest { - catch { - proc p x { - set y [string tolower $x] - return "$x:$y" - } - set rv [p P] - procbodytest::proc t {x x1 x2} p - lappend rv [t T] - set rv - } result +} -result {P:p T:t} +test proc-4.3 {TclCreateProc, procbody obj, too many args} -body { + proc p x { + set y [string tolower $x] + return "$x:$y" + } + set rv [p P] + procbodytest::proc t {x x1 x2} p + lappend rv [t T] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": arg list contains 3 entries, precompiled header expects 1} -test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} procbodytest { - catch { - proc p {x y z} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x x1 z} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": arg list contains 3 entries, precompiled header expects 1} +test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} -body { + proc p {x y z} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x x1 z} p + lappend rv [t S T U] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter 1 is inconsistent with precompiled body} -test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} procbodytest { - catch { - proc p {x y {z Z}} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x y z} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": formal parameter 1 is inconsistent with precompiled body} +test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body { + proc p {x y {z Z}} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y z} p + lappend rv [t S T U] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter 2 is inconsistent with precompiled body} -test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} procbodytest { - catch { - proc p {x y z} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x y {z Z}} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} +test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body { + proc p {x y z} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y {z Z}} p + lappend rv [t S T U] +} -returnCodes error -constraints procbodytest -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter 2 is inconsistent with precompiled body} -test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} procbodytest { - catch { - proc p {x y {z Z}} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x y {z ZZ}} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} +test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -body { + proc p {x y {z Z}} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y {z ZZ}} p + lappend rv [t S T U] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} +} -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup { proc getbytes {} { set lines [split [memory info] "\n"] @@ -310,12 +299,9 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set } px x } -constraints {procbodytest memory} -body { - set end [getbytes] for {set i 0} {$i < 5} {incr i} { - procbodytest::proc tx x px - set tmp $end set end [getbytes] } @@ -325,7 +311,7 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set unset -nocomplain end i tmp leakedBytes } -result 0 -test proc-5.1 {Bytecompiling noop; test for correct argument substitution} { +test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body { proc p args {} ; # this will be bytecompiled into t proc t {} { set res {} @@ -336,20 +322,20 @@ test proc-5.1 {Bytecompiling noop; test for correct argument substitution} { p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello set res } - set result [t] + t +} -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {aba} +} -result {aba} -test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} { +test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} -body { proc a {} {return -code -5} proc b {} a - set result [catch b] + catch b +} -cleanup { rename a {} rename b {} - set result -} -5 +} -result -5 test proc-7.1 {Redefining a compiled cmd: Bug 729692} { proc bar args {} @@ -359,19 +345,17 @@ test proc-7.1 {Redefining a compiled cmd: Bug 729692} { } foo } bar - -test proc-7.2 {Shadowing a compiled cmd: Bug 729692} { +test proc-7.2 {Shadowing a compiled cmd: Bug 729692} -body { namespace eval ugly {} proc ugly::foo {} { proc set args {return bar} set x 1 } - set res [list [catch {ugly::foo} msg] $msg] + ugly::foo +} -cleanup { namespace delete ugly - set res -} {0 bar} - -test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} { +} -result bar +test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body { namespace eval ugly {} proc ugly::foo {} { set i 0 @@ -383,15 +367,18 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} { } return $i } - set res [list [catch {ugly::foo} msg] $msg] + ugly::foo +} -cleanup { namespace delete ugly - set res -} {0 4} - - - +} -result 4 + # cleanup catch {rename p ""} catch {rename t ""} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/security.test b/tests/security.test index 2549a4a..e92775e 100644 --- a/tests/security.test +++ b/tests/security.test @@ -1,18 +1,18 @@ # security.test -- # -# Functionality covered: this file contains a collection of tests for the -# auto loading and namespaces. +# Functionality covered: this file contains a collection of tests for the auto +# loading and namespaces. # -# 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. # All rights reserved. # -# RCS: @(#) $Id: security.test,v 1.6 2004/05/19 13:02:10 dkf Exp $ +# RCS: @(#) $Id: security.test,v 1.7 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -41,3 +41,7 @@ test security-1.1 {tcl_endOfPreviousWord} { # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/switch.test b/tests/switch.test index 738565f..3f127a4 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -11,13 +11,13 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: switch.test,v 1.25 2009/07/14 16:52:28 kennykb Exp $ +# RCS: @(#) $Id: switch.test,v 1.26 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } - + test switch-1.1 {simple patterns} { switch a a {subst 1} b {subst 2} c {subst 3} default {subst 4} } 1 @@ -753,7 +753,7 @@ test switch-15.1 {coroutine safety of non-bytecoded switch} {*}{ rename coro {} } } - + # cleanup catch {rename foo {}} ::tcltest::cleanupTests diff --git a/tests/unixInit.test b/tests/unixInit.test index 1f4dc7a..1f5c7c1 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -1,23 +1,23 @@ # The file tests the functions in the tclUnixInit.c file. # -# 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) 1997 by 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: unixInit.test,v 1.50 2006/11/03 11:45:35 dkf Exp $ +# RCS: @(#) $Id: unixInit.test,v 1.51 2011/01/01 15:14:43 dkf Exp $ package require tcltest 2.2 namespace import -force ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C - + test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} # Watch out for a race condition here. If tcltest is too slow to start @@ -36,13 +36,13 @@ test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { lappend x [catch {close $f}] set x } {0 1} -# This test is really a test of code in tclUnixChan.c, but the -# channels are set up as part of initialisation of the interpreter so -# the test seems to me to fit here as well as anywhere else. +# This test is really a test of code in tclUnixChan.c, but the channels are +# set up as part of initialisation of the interpreter so the test seems to me +# to fit here as well as anywhere else. test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} { - # pipe1 is a connection to a server that reports what port it - # starts on, and delivers a constant string to the first client to - # connect to that port before exiting. + # pipe1 is a connection to a server that reports what port it starts on, + # and delivers a constant string to the first client to connect to that + # port before exiting. set pipe1 [open "|[list [interpreter]]" r+] puts $pipe1 { proc accept {channel host port} { @@ -53,16 +53,16 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} puts [fconfigure [socket -server accept -myaddr 127.0.0.1 0] -sockname] vwait forever \ } - # Note the backslash above; this is important to make sure that the - # whole string is read before an [exit] can happen... + # Note the backslash above; this is important to make sure that the whole + # string is read before an [exit] can happen... flush $pipe1 set port [lindex [gets $pipe1] 2] set sock [socket localhost $port] - # pipe2 is a connection to a Tcl interpreter that takes its orders - # from the socket we hand it (i.e. the server we create above.) - # These orders will tell it to print out the details about the - # socket it is taking instructions from, hopefully identifying it - # as a socket. Which is what this test is all about. + # pipe2 is a connection to a Tcl interpreter that takes its orders from + # the socket we hand it (i.e. the server we create above.) These orders + # will tell it to print out the details about the socket it is taking + # instructions from, hopefully identifying it as a socket. Which is what + # this test is all about. set pipe2 [open "|[list [interpreter] <@$sock]" r] set result [gets $pipe2] # Clear any pending data; stops certain kinds of (non-important) errors @@ -85,8 +85,8 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} } {OK} # The unixInit-2.* tests were written to test the internal routine, -# TclpInitLibraryPath. That routine no longer does the things it used -# to do so those tests are obsolete. Skip them. +# TclpInitLibraryPath. That routine no longer does the things it used to do +# so those tests are obsolete. Skip them. skip [concat [skip] unixInit-2.*] @@ -207,10 +207,9 @@ test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} { # [lindex $auto_path end] } {} # -# The following two tests write to the directory /tmp/sparkly instead -# of to [temporaryDirectory]. This is because the failures tested by -# these tests need paths near the "root" of the file system to present -# themselves. +# The following two tests write to the directory /tmp/sparkly instead of to +# [temporaryDirectory]. This is because the failures tested by these tests +# need paths near the "root" of the file system to present themselves. # test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { unset -nocomplain oldlibrary @@ -219,20 +218,20 @@ test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { } set env(TCL_LIBRARY) [info library] # Checking for Bug 219416 - # When a program that embeds the Tcl library, like tcltest, is - # installed near the "root" of the file system, there was a problem - # constructing directories relative to the executable. When a - # relative ".." went past the root, relative path names were created - # rather than absolute pathnames. In some cases, accessing past the - # root caused memory access violations too. + # When a program that embeds the Tcl library, like tcltest, is installed + # near the "root" of the file system, there was a problem constructing + # directories relative to the executable. When a relative ".." went past + # the root, relative path names were created rather than absolute + # pathnames. In some cases, accessing past the root caused memory access + # violations too. # - # The bug is now fixed, but here we check for it by making sure that - # the directories constructed relative to the executable are all - # absolute pathnames, even when the executable is installed near - # the root of the filesystem. + # The bug is now fixed, but here we check for it by making sure that the + # directories constructed relative to the executable are all absolute + # pathnames, even when the executable is installed near the root of the + # filesystem. # - # The only directory near the root we are likely to have write access - # to is /tmp. + # The only directory near the root we are likely to have write access to + # is /tmp. file delete -force /tmp/sparkly file delete -force /tmp/lib/tcl[info tclversion] file mkdir /tmp/sparkly @@ -367,12 +366,11 @@ test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} { catch {set env(LC_ALL) $oldlc_all} set validEncodings [list euc-jp] if {[string match HP-UX $tcl_platform(os)]} { - # Some older HP-UX systems need us to accept this as valid - # Bug 453883 reports that newer HP-UX systems report euc-jp - # like everybody else. + # Some older HP-UX systems need us to accept this as valid Bug 453883 + # reports that newer HP-UX systems report euc-jp like everybody else. lappend validEncodings shiftjis } - expr {[lsearch -exact $validEncodings $enc] < 0} + expr {$enc ni $validEncodings} } 0 test unixInit-4.1 {TclpSetVariables} {unix} { @@ -403,7 +401,7 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { removeFile crash.tcl removeFile crashtest.tcl } -returnCodes 0 - + # cleanup catch {unset env(LANG)} catch {set env(LANG) $oldlang} @@ -411,3 +409,7 @@ unset -nocomplain path ::tcltest::cleanupTests return +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/var.test b/tests/var.test index 01be5a4..8913204 100644 --- a/tests/var.test +++ b/tests/var.test @@ -14,7 +14,7 @@ # 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.37 2010/12/07 16:32:06 dkf Exp $ +# RCS: @(#) $Id: var.test,v 1.38 2011/01/01 15:14:43 dkf Exp $ # if {"::tcltest" ni [namespace children]} { @@ -118,9 +118,9 @@ test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of va set x:y: 789 list [set :] [set v:] [set x:y:] \ ${:} ${v:} ${x:y:} \ - [expr {[lsearch [info vars] :] != -1}] \ - [expr {[lsearch [info vars] v:] != -1}] \ - [expr {[lsearch [info vars] x:y:] != -1}] + [expr {":" in [info vars]}] \ + [expr {"v:" in [info vars]}] \ + [expr {"x:y:" in [info vars]}] } } {123 456 789 123 456 789 1 1 1} test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} { diff --git a/tests/winDde.test b/tests/winDde.test index f59a7f2..a819f93 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -9,9 +9,9 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winDde.test,v 1.28 2005/05/10 18:35:25 kennykb Exp $ +# RCS: @(#) $Id: winDde.test,v 1.29 2011/01/01 15:14:43 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* @@ -49,7 +49,7 @@ proc createChildProcess { ddeServerName {handler {}}} { puts $f { # DDE child server - # - if {[lsearch [namespace children] ::tcltest] == -1} { + if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -267,7 +267,7 @@ test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup { dde services TclEval {} set s [dde services TclEval {}] set m [list [list TclEval dde-interp-7.5]] - if {[lsearch -exact $s $m] != -1} { + if {$m in $s} { set s } } -result {} diff --git a/tests/winPipe.test b/tests/winPipe.test index 1700fa2..632f8e7 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -9,16 +9,15 @@ # Copyright (c) 1996 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: winPipe.test,v 1.34 2010/10/06 20:21:39 dgp Exp $ +# RCS: @(#) $Id: winPipe.test,v 1.35 2011/01/01 15:14:43 dkf Exp $ package require tcltest namespace import -force ::tcltest::* unset -nocomplain path - set bindir [file join [pwd] [file dirname [info nameofexecutable]]] set cat32 [file join $bindir cat32.exe] @@ -60,7 +59,7 @@ set path(more) [makeFile { set path(stdout) [makeFile {} stdout] set path(stderr) [makeFile {} stderr] - + test winpipe-1.1 {32 bit comprehensive tests: from little file} {win exec cat32} { exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] @@ -185,7 +184,6 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { set result "$result$line" } } - set f [open "|[list $cat32] < $path(big) 2> $path(stderr)" r] fconfigure $f -buffering none -blocking 0 fileevent $f readable "readResults $f" @@ -237,7 +235,7 @@ test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {win exec} { set existing [glob -nocomplain c:/tcl*.tmp] exec [interpreter] < $path(nothing) foreach p [glob -nocomplain c:/tcl*.tmp] { - if {[lsearch $existing $p] == -1} { + if {$p ni $existing} { lappend x $p } } @@ -312,7 +310,6 @@ set path(echoArgs.tcl) [makeFile { puts "[list $argv0 $argv]" } echoArgs.tcl] - ### validate the raw output of BuildCommandLine(). ### test winpipe-7.1 {BuildCommandLine: null arguments} {win exec} { @@ -429,7 +426,7 @@ test winpipe-8.18 {BuildCommandLine/parse_cmdline pass-thru: special chars #2} { test winpipe-8.19 {ensure parse_cmdline isn't doing wildcard replacement} {win exec} { exec [interpreter] $path(echoArgs.tcl) foo * makefile.?c bar } [list $path(echoArgs.tcl) [list foo * makefile.?c bar]] - + # restore old values for env(TMP) and env(TEMP) if {[catch {set env(TMP) $env_tmp}]} { @@ -449,3 +446,7 @@ removeFile nothing removeFile echoArgs.tcl ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: |