diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2013-12-30 08:50:28 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2013-12-30 08:50:28 (GMT) |
commit | 6418dc63fd2459110ec65445bbc611c4aa2e32fe (patch) | |
tree | 2af8a18fefd4c3bf00798b38a98ad9839ff87342 /tests | |
parent | dfe92fee6cdcf5ae490fb332111618fbb08a6bdd (diff) | |
parent | 1749e8cdf33e8232f22acc08f9ce4301b00ba7eb (diff) | |
download | tcl-6418dc63fd2459110ec65445bbc611c4aa2e32fe.zip tcl-6418dc63fd2459110ec65445bbc611c4aa2e32fe.tar.gz tcl-6418dc63fd2459110ec65445bbc611c4aa2e32fe.tar.bz2 |
merge main working branch
Diffstat (limited to 'tests')
64 files changed, 2940 insertions, 809 deletions
diff --git a/tests/assemble.test b/tests/assemble.test index 7d4e5d1..b0487e6 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} { -match glob -result {1 {extra characters after close-brace} {extra characters after close-brace while executing -"{}extra - " +"{}e" ("assemble" body, line 2)*}} } test assemble-4.2 {null command} { diff --git a/tests/assocd.test b/tests/assocd.test index d1489b3..edf55c4 100644 --- a/tests/assocd.test +++ b/tests/assocd.test @@ -11,10 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -36,15 +34,21 @@ test assocd-1.4 {testing setting assoc data} testsetassocdata { testsetassocdata abc "abc d e f" } "" -test assocd-2.1 {testing getting assoc data} testgetassocdata { - testgetassocdata a -} 2 -test assocd-2.2 {testing getting assoc data} testgetassocdata { - testgetassocdata 123 -} 456 -test assocd-2.3 {testing getting assoc data} testgetassocdata { +test assocd-2.1 {testing getting assoc data} -setup { + testsetassocdata a 2 +} -constraints {testgetassocdata} -body { + testgetassocdata a +} -result 2 +test assocd-2.2 {testing getting assoc data} -setup { + testsetassocdata 123 456 +} -constraints {testgetassocdata} -body { + testgetassocdata 123 +} -result 456 +test assocd-2.3 {testing getting assoc data} -setup { + testsetassocdata abc "abc d e f" +} -constraints {testgetassocdata} -body { testgetassocdata abc -} {abc d e f} +} -result "abc d e f" test assocd-2.4 {testing getting assoc data} testgetassocdata { testgetassocdata xxx } "" @@ -60,5 +64,5 @@ test assocd-3.3 {testing deleting assoc data} testdelassocdata { } {0 {}} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 8f29131..4721553 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -236,6 +236,38 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} -setup { # Reset initCommands to avoid trashing other tests AutoMkindexTestReset } -result "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}" +makeFile { + +namespace eval wok { + namespace ensemble create -subcommands {commands vars} + + proc commands {{pattern *}} { + puts [join [lsort -dictionary [info commands $pattern]] \n] + } + + proc vars {{pattern *}} { + puts [join [lsort -dictionary [info vars $pattern]] \n] + } + +} + +} ensemblecommands.tcl + +test autoMkindex-3.4 {ensemble commands in tclIndex} { + file delete tclIndex + auto_mkindex . ensemblecommands.tcl + set f [open tclIndex r] + set dat [list] + foreach r [split [string trim [read $f]] "\n"] { + if {[string match {set auto_index*} $r]} { + lappend dat $r + } + } + set result [lsort $dat] + close $f + set result +} {{set auto_index(::wok::commands) [list source [file join $dir ensemblecommands.tcl]]} {set auto_index(::wok::vars) [list source [file join $dir ensemblecommands.tcl]]} {set auto_index(wok) [list source [file join $dir ensemblecommands.tcl]]}} +removeFile ensemblecommands.tcl test autoMkindex-4.1 {platform independent source commands} -setup { file delete tclIndex diff --git a/tests/basic.test b/tests/basic.test index 7435571..1a0037c 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -16,7 +16,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 -namespace import -force ::tcltest::* +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -31,7 +31,7 @@ catch {interp delete test_interp} catch {rename p ""} catch {rename q ""} catch {rename cmd ""} -catch {unset x} +unset -nocomplain x test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { catch {interp delete test_interp} @@ -267,14 +267,24 @@ test basic-18.4 {TclRenameCommand, bad new name} { } rename test_ns_basic::p :::george::martha } {} -test basic-18.5 {TclRenameCommand, new name must not already exist} { +test basic-18.5 {TclRenameCommand, new name must not already exist} -setup { + if {![llength [info commands :::george::martha]]} { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_basic { + proc p {} { + return "p in [namespace current]" + } + } + rename test_ns_basic::p :::george::martha + } +} -body { namespace eval test_ns_basic { proc q {} { return 42 } } list [catch {rename test_ns_basic::q :::george::martha} msg] $msg -} {1 {can't rename to ":::george::martha": command already exists}} +} -result {1 {can't rename to ":::george::martha": command already exists}} test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} @@ -302,7 +312,7 @@ test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespace catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} - catch {unset x} + unset -nocomplain x set x [namespace eval test_ns_basic::test_ns_basic2 { # the following creates a cmd in the global namespace testcmdtoken create p @@ -355,7 +365,7 @@ test basic-23.1 {Tcl_DeleteCommand} {emptyTest} { test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { catch {interp delete test_interp} - catch {unset x} + unset -nocomplain x interp create test_interp interp eval test_interp { proc useSet {} { @@ -427,7 +437,7 @@ test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup { # string would have been freed, leaving garbage bytes for the error # message. set f [open $fName w] - fileevent $f writable "fileevent $f writable {}; error foo" + chan event $f writable "chan event $f writable {}; error foo" set x {} vwait x close $f @@ -547,8 +557,8 @@ test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} { catch {close $f} set res [catch { set f [open |[list [interpreter]] w+] - fconfigure $f -buffering line - puts $f {fconfigure stdout -buffering line} + chan configure $f -buffering line + puts $f {chan configure stdout -buffering line} puts $f continue puts $f {puts $::errorInfo} puts $f {puts DONE} @@ -972,6 +982,6 @@ catch {rename p ""} catch {rename q ""} catch {rename cmd ""} catch {rename value:at: ""} -catch {unset x} -::tcltest::cleanupTests +unset -nocomplain x +cleanupTests return diff --git a/tests/binary.test b/tests/binary.test index ccd0f29..40b1315 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -1582,38 +1582,46 @@ test binary-40.4 {ScanNumber: NaN} -body { list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1 } -match glob -result {1 -NaN*} -test binary-41.1 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +test binary-41.1 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.2 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.2 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.3 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.3 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.4 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.4 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.5 {ScanNumber: word alignment} bigEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.5 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints bigEndian -body { list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2 -} {2 1 1.600000023841858} -test binary-41.6 {ScanNumber: word alignment} littleEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1.600000023841858} +test binary-41.6 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints littleEndian -body { list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2 -} {2 1 1.600000023841858} -test binary-41.7 {ScanNumber: word alignment} bigEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1.600000023841858} +test binary-41.7 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints bigEndian -body { list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2 -} {2 1 1.6} -test binary-41.8 {ScanNumber: word alignment} littleEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1.6} +test binary-41.8 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints littleEndian -body { list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2 -} {2 1 1.6} +} -result {2 1 1.6} test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} -constraints {} -body { binary ? @@ -2491,6 +2499,34 @@ test binary-71.9 {binary decode hex} -body { test binary-71.10 {binary decode hex} -body { string length [binary decode hex " "] } -result 0 +test binary-71.11 {binary decode hex: Bug b98fa55285} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {29 38} +test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} test binary-72.1 {binary encode base64} -body { binary encode base64 @@ -2669,105 +2705,116 @@ test binary-74.1 {binary encode uuencode} -body { } -returnCodes error -match glob -result "wrong # args: *" test binary-74.2 {binary encode uuencode} -body { binary encode uuencode abc -} -result {86)C} +} -result {#86)C +} test binary-74.3 {binary encode uuencode} -body { binary encode uuencode {} } -result {} test binary-74.4 {binary encode uuencode} -body { binary encode uuencode [string repeat abc 20] -} -result [string repeat 86)C 20] +} -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" test binary-74.5 {binary encode uuencode} -body { binary encode uuencode \0\1\2\3\4\0\1\2\3 -} -result "``\$\"`P0``0(#" +} -result ")``\$\"`P0``0(#\n" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 -} -result {````} +} -result {!`` +} test binary-74.7 {binary encode uuencode} -body { binary encode uuencode \0\0 -} -result {````} +} -result "\"``` +" test binary-74.8 {binary encode uuencode} -body { binary encode uuencode \0\0\0 -} -result {````} +} -result {#```` +} test binary-74.9 {binary encode uuencode} -body { binary encode uuencode \0\0\0\0 -} -result {````````} -test binary-74.10 {binary encode uuencode} -body { - binary encode uuencode -maxlen 0 -wrapchar | abcabcabc -} -result {86)C86)C86)C} -test binary-74.11 {binary encode uuencode} -body { - binary encode uuencode -maxlen 1 -wrapchar | abcabcabc -} -result {8|6|)|C|8|6|)|C|8|6|)|C} +} -result {$`````` +} +test binary-74.10 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -foo 30 abcabcabc +} -result {bad option "-foo": must be -maxlen or -wrapchar} +test binary-74.11 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 1 abcabcabc +} -result {line length out of range} +test binary-74.12 {binary encode uuencode} -body { + binary encode uuencode -maxlen 3 -wrapchar | abcabcabc +} -result {!80|!8@|!8P|!80|!8@|!8P|!80|!8@|!8P|} test binary-75.1 {binary decode uuencode} -body { binary decode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-75.2 {binary decode uuencode} -body { - binary decode uuencode 86)C + binary decode uuencode "#86)C\n" } -result {abc} test binary-75.3 {binary decode uuencode} -body { binary decode uuencode {} } -result {} +test binary-75.3.1 {binary decode uuencode} -body { + binary decode uuencode `\n +} -result {} test binary-75.4 {binary decode uuencode} -body { - binary decode uuencode [string repeat "86)C" 20] + binary decode uuencode "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { - binary decode uuencode "``\$\"`P0``0(#" + binary decode uuencode ")``\$\"`P0``0(#" } -result "\0\1\2\3\4\0\1\2\3" test binary-75.6 {binary decode uuencode} -body { - string length [binary decode uuencode {`}] + string length [binary decode uuencode "`\n"] } -result 0 test binary-75.7 {binary decode uuencode} -body { - string length [binary decode uuencode {``}] + string length [binary decode uuencode "!`\n"] } -result 1 test binary-75.8 {binary decode uuencode} -body { - string length [binary decode uuencode {```}] + string length [binary decode uuencode "\"``\n"] } -result 2 test binary-75.9 {binary decode uuencode} -body { - string length [binary decode uuencode {````}] + string length [binary decode uuencode "#```\n"] } -result 3 test binary-75.10 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n>[string repeat 86)C 10]" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.11 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { binary decode uuencode -strict "|86)C" } -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} test binary-75.13 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]|[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]|[string repeat 86)C 10]" binary decode uuencode -strict $s -} -returnCodes error -match glob -result {invalid uuencode character "|" at position 40} +} -returnCodes error -match glob -result {invalid uuencode character "|" at position 41} test binary-75.14 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]" binary decode uuencode -strict $s } -returnCodes error -match glob -result {invalid uuencode character *} test binary-75.20 {binary decode uuencode} -body { - set r [binary decode uuencode 8] + set r [binary decode uuencode " 8"] list [string length $r] $r } -result {0 {}} test binary-75.21 {binary decode uuencode} -body { - set r [binary decode uuencode 86] + set r [binary decode uuencode "!86"] list [string length $r] $r } -result {1 a} test binary-75.22 {binary decode uuencode} -body { - set r [binary decode uuencode 86)] + set r [binary decode uuencode "\"86)"] list [string length $r] $r } -result {2 ab} test binary-75.23 {binary decode uuencode} -body { - set r [binary decode uuencode 86)C] + set r [binary decode uuencode "#86)C"] list [string length $r] $r } -result {3 abc} test binary-75.24 {binary decode uuencode} -body { - set s "04)\# " + set s "#04)\# " binary decode uuencode $s } -result ABC test binary-75.25 {binary decode uuencode} -body { - set s "04)\#z" + set s "#04)\#z" binary decode uuencode $s -} -returnCodes error -match glob -result {invalid uuencode character "z" at position 4} +} -returnCodes error -match glob -result {invalid uuencode character "z" at position 5} test binary-75.26 {binary decode uuencode} -body { string length [binary decode uuencode " "] } -result 0 diff --git a/tests/chanio.test b/tests/chanio.test index 665df50..999d0bb 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -2214,13 +2214,17 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { puts $sok DONE exit 0 } echo.tcl] -} -body { + variable done + unset -nocomplain done + set done "" + set timer "" set ff [openpipe r $echo] gets $ff port +} -body { set s [socket 127.0.0.1 $port] puts $s Hey close $s w - set timer [after 1000 [namespace code {set ::done Failed}]] + set timer [after 1000 [namespace code {set done Failed}]] set acc {} fileevent $s readable [namespace code { if {[gets $s line]<0} { @@ -2230,11 +2234,11 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { } }] vwait [namespace which -variable done] - after cancel $timer - close $s r - close $ff list $done $acc } -cleanup { + catch {close $s} + close $ff + after cancel $timer removeFile echo.tcl } -result {Succeeded {Hey DONE}} diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3051bfb..39e9ece 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -954,6 +954,19 @@ test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup { removeFile /tmp/tcl.foo.dir/file removeDirectory /tmp/tcl.foo.dir } -result 0 +test cmdAH-19.12 {Bug 3608360: [file exists] mustn't do globbing} -setup { + set newdirfile [makeDirectory newdir.file] + set cwd [pwd] + cd $newdirfile + # Content of file is totally unimportant; name is *not* + set innocentBystander [makeFile "abc" [file join $newdirfile foo.bar]] +} -body { + list [file exists foo.bar] [file exists *.bar] +} -cleanup { + cd $cwd + removeFile $innocentBystander + removeDirectory $newdirfile +} -result {1 0} # Stat related commands diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 721773f..23a5f96 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -417,6 +417,15 @@ test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} { test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} { lsort -ascii -nocase {d E c B a D35 d300 100 20} } {100 20 a B c d d300 D35 E} +test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list \u101 \u100]] %c%c%c +} {257 32 256} +test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c +} {97 32 97 0 97} +test cmdIL-4.38 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list a a\u0000a]] %c%c%c%c%c +} {97 32 97 0 97} test cmdIL-5.1 {lsort with list style index} { lsort -ascii -decreasing -index {0 1} { diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index 69d7171..0a587e8 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -13,10 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -101,7 +99,7 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} \ # cleanup catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1} catch {rename x1 ""} -::tcltest::cleanupTests +cleanupTests return # Local Variables: diff --git a/tests/compile.test b/tests/compile.test index 4d91940..2852bf2 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -167,6 +167,36 @@ test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*} -cleanup {namespace delete catchtest} } +test compile-3.7 {TclCompileCatchCmd: error in storing options [Bug 3098302]} {*}{ + -setup { + namespace eval catchtest { + variable options1 {} + } + trace add variable catchtest::options1 write catchtest::failtrace + proc catchtest::failtrace {n1 n2 op} { + return -code error "trace on $n1 fails by request" + } + } + -body { + proc catchtest::x {} { + variable options1 + set count 0 + for {set i 0} {$i < 10} {incr i} { + set status2 [catch { + set status1 [catch { + return -code error -level 0 "original failure" + } result1 options1] + } result2 options2] + incr count + } + list $count $result2 + } + catchtest::x + } + -result {10 {can't set "options1": trace on options1 fails by request}} + -cleanup {namespace delete catchtest} +} + test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 set j 0 @@ -707,6 +737,76 @@ test compile-18.19 {disassembler - basics} -setup { } -cleanup { foo destroy } -match glob -result * + +test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { + # This will panic in a --enable-symbols=compile build, unless bug is fixed. + apply {{} {list [if 1]}} +} -returnCodes error -match glob -result * + +test compile-20.1 {ensure there are no infinite loops in optimizing} { + tcl::unsupported::disassemble script { + while 1 { + return -code continue -level 0 + } + } + return +} {} +test compile-20.2 {ensure there are no infinite loops in optimizing} { + tcl::unsupported::disassemble script { + while 1 { + while 1 { + return -code break -level 0 + } + } + } + return +} {} + +test compile-21.1 {stack balance management} { + apply {{} { + set result {} + while 1 { + lappend result a + lappend result [list b [break]] + lappend result c + } + return $result + }} +} a +test compile-21.2 {stack balance management} { + apply {{} { + set result {} + while {[incr i] <= 10} { + lappend result $i + lappend result [list b [continue] c] + lappend result c + } + return $result + }} +} {1 2 3 4 5 6 7 8 9 10} +test compile-21.3 {stack balance management} { + apply {args { + set result {} + while 1 { + lappend result a + lappend result [concat {*}$args [break]] + lappend result c + } + return $result + }} P Q R S T +} a +test compile-21.4 {stack balance management} { + apply {args { + set result {} + while {[incr i] <= 10} { + lappend result $i + lappend result [concat {*}$args [continue] c] + lappend result c + } + return $result + }} P Q R S T +} {1 2 3 4 5 6 7 8 9 10} + # TODO sometime - check that bytecode from tbcload is *not* disassembled. # cleanup diff --git a/tests/coroutine.test b/tests/coroutine.test index 8272717..a360fd5 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -342,6 +342,9 @@ test coroutine-3.6 {info frame, bug #2910094} -setup { rename stack {} rename a {} } -result {} +test coroutine-3.7 {bug 0b874c344d} { + dict get [coroutine X coroutine Y info frame 0] cmd +} {coroutine X coroutine Y info frame 0} test coroutine-4.1 {bug #2093188} -setup { proc foo {} { @@ -439,7 +442,7 @@ test coroutine-4.5 {bug #2724403} -constraints {memory} \ } -result 0 test coroutine-4.6 {compile context, bug #3282869} -setup { - unset ::x + unset -nocomplain ::x proc f x { coroutine D eval {yield X$x;yield Y} } @@ -609,6 +612,39 @@ test coroutine-7.3 {yielding between coroutines} -body { } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} + +test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { + proc foo {a b} {catch yield; return 1} +} -cleanup { + rename foo {} +} -body { + coroutine demo lsort -command foo {a b} +} -result {b a} + +test coroutine-7.5 {return codes} { + set result {} + foreach code {0 1 2 3 4 5} { + lappend result [catch {coroutine demo return -level 0 -code $code}] + } + set result +} {0 1 2 3 4 5} + +test coroutine-7.6 {Early yield crashes} { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} +} {} + +test coroutine-7.7 {Bug 2486550} -setup { + interp hide {} yield +} -body { + coroutine demo interp invokehidden {} yield ok +} -cleanup { + demo + interp expose {} yield +} -result ok + # cleanup unset lambda diff --git a/tests/dcall.test b/tests/dcall.test index 3df0ac8..41dd777 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -11,10 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -41,5 +39,5 @@ test dcall-1.6 {deletion callbacks} testdcall { } {} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/dict.test b/tests/dict.test index 72a336c..a583de8 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -668,6 +668,24 @@ test dict-14.20 {dict for stack space compilation: bug 1903325} { concat "c=$y,$args" }} {} 1 2 3 } {c=1,2 3} +test dict-14.21 {compiled dict for and break} { + apply {{} { + dict for {a b} {c d e f} { + lappend result $a,$b + break + } + return $result + }} +} c,d +test dict-14.22 {dict for and exception range depths: Bug 3614382} { + apply {{} { + dict for {a b} {c d} { + dict for {e f} {g h} { + return 5 + } + } + }} +} 5 # There's probably a lot more tests to add here. Really ought to use a # coverage tool for this job... @@ -1586,7 +1604,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} { } }} [linenumber]}} } 5 -test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { +test dict-23.2 {dict compilation crash: Bug 3487626} { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are @@ -1820,7 +1838,7 @@ test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} { } }} [linenumber]}} } 5 -test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug { +test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} { apply {{} {apply {n { set e {} set k {} @@ -1847,6 +1865,77 @@ j } }} [linenumber]}} } 5 +test dict-23.3 {CompileWord OBOE} { + # segfault when buggy + apply {{} {tcl::dict::lappend foo bar \ + [format baz]}} +} {bar baz} +test dict-23.4 {CompileWord OBOE} { + apply {n { + dict set foo {*}{ + } [return [incr n -[linenumber]]] val + }} [linenumber] +} 1 +test dict-23.5 {CompileWord OBOE} { + # segfault when buggy + apply {{} {tcl::dict::incr foo \ + [format bar]}} +} {bar 1} +test dict-23.6 {CompileWord OBOE} { + apply {n { + dict get {a b} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 +test dict-23.7 {CompileWord OBOE} { + apply {n { + dict for {a b} [return [incr n -[linenumber]]] {*}{ + } {} + }} [linenumber] +} 2 +test dict-23.8 {CompileWord OBOE} { + apply {n { + dict update foo {*}{ + } [return [incr n -[linenumber]]] x {} + }} [linenumber] +} 1 +test dict-23.9 {CompileWord OBOE} { + apply {n { + dict exists {} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 +test dict-23.10 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.11 {CompileWord OBOE} { + apply {n { + dict with ::foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.12 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.13 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 +test dict-23.14 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 + rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { diff --git a/tests/env.test b/tests/env.test index 9010f52..83d99e0 100644 --- a/tests/env.test +++ b/tests/env.test @@ -70,7 +70,7 @@ set printenvScript [makeFile { } proc mangle s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all {[\u0000-\u001f\u007f-\uffff]} $s {[manglechar &]} s + regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s return [subst -novariables $s] } proc manglechar c { @@ -89,7 +89,7 @@ set printenvScript [makeFile { SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles + CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 } { lrem names $name } @@ -121,7 +121,7 @@ foreach name [array names env] { SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles + CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432 }} { unset env($name) } @@ -218,8 +218,8 @@ test env-4.5 {unsetting international environment variables} -setup { unset env(\ua7) getenv } -constraints {exec} -cleanup { - encoding system $sysenc unset env(\ub6) + encoding system $sysenc } -result {\u00b6=\u00a7} test env-5.0 {corner cases - set a value, it should exist} -body { @@ -291,6 +291,29 @@ test env-6.1 {corner cases - add lots of env variables} {} { expr {[array size env] - $size} } 100 +test env-7.1 {[219226]: whole env array should not be unset by read} { + set n [array size env] + set s [array startsearch env] + while {[array anymore env $s]} { + array nextelement env $s + incr n -1 + } + array donesearch env $s + return $n +} 0 +test env-7.2 {[219226]: links to env elements should not be removed by read} { + apply {{} { + set ::env(test7_2) ok + upvar env(test7_2) elem + set ::env(PATH) + try { + return $elem + } finally { + unset ::env(test7_2) + } + }} +} ok + # Restore the environment variables at the end of the test. foreach name [array names env] { diff --git a/tests/error.test b/tests/error.test index 97bcc0a..0de644c 100644 --- a/tests/error.test +++ b/tests/error.test @@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } testConstraint memory [llength [info commands memory]] +customMatch pairwise {apply {{a b} { + string equal [lindex $b 0] [lindex $b 1] +}}} namespace eval ::tcl::test::error { if {[testConstraint memory]} { proc getbytes {} { @@ -179,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body { catch {f 12} m d dict get $d -errorstack } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} +test error-4.8 {errorstack from exec traces} -body { + proc foo args {} + proc goo {} foo + trace add execution foo enter {error bar;#} + catch goo m d + dict get $d -errorstack +} -cleanup { + rename goo {}; rename foo {} + unset -nocomplain m d +} -result {INNER {error bar} CALL goo UP 1} # Errors in error command itself @@ -314,6 +327,12 @@ test error-8.8 {throw syntax checks} -returnCodes error -body { test error-8.9 {throw syntax checks} -returnCodes error -body { throw {} foo } -result {type must be non-empty list} +test error-8.10 {Bug 33b7abb8a2: throw stack usage} -returnCodes error -body { + apply {code {throw $code foo}} {} +} -result {type must be non-empty list} +test error-8.11 {Bug 7174354ecb: throw error message} -returnCodes error -body { + throw {not {}a list} x[]y +} -result {list element in braces followed by "a" instead of space} # simple try tests: body completes with code ok @@ -601,21 +620,21 @@ test error-16.7 {try with variable assignment and propagation #2} { } list $em [dict get $opts -errorcode] } {bar FOO} -test error-16.8 {exception chaining (try=ok, handler=error)} { +test error-16.8 {exception chaining (try=ok, handler=error)} -body { #FIXME is the intent of this test correct? catch { try { list a b c } on ok {em opts} { throw BAR baz } } tryem tryopts - string equal $opts [dict get $tryopts -during] -} {1} -test error-16.9 {exception chaining (try=error, handler=error)} { + list $opts [dict get $tryopts -during] +} -match pairwise -result equal +test error-16.9 {exception chaining (try=error, handler=error)} -body { # The exception off the handler should chain to the exception off the # try-body (using the -during option) catch { try { throw FOO bar } trap {} {em opts} { throw BAR baz } } tryem tryopts - string equal $opts [dict get $tryopts -during] -} {1} + list $opts [dict get $tryopts -during] +} -match pairwise -result equal test error-16.10 {no exception chaining when handler is successful} { catch { try { throw FOO bar } trap {} {em opts} { list d e f } @@ -628,6 +647,131 @@ test error-16.11 {no exception chaining when handler is a non-error exception} { } tryem tryopts dict exists $tryopts -during } {0} +test error-16.12 {compiled try with successfully executed handler} { + apply {{} { + try { throw FOO bar } trap FOO {} { list a b c } + }} +} {a b c} +test error-16.13 {compiled try with exception (error) in handler} -body { + apply {{} { + try { throw FOO bar } trap FOO {} { throw BAR foo } + }} +} -returnCodes error -result {foo} +test error-16.14 {compiled try with exception (return) in handler} -body { + apply {{} { + list [catch { + try { throw FOO bar } trap FOO {} { return BAR } + } msg] $msg + }} +} -result {2 BAR} +test error-16.15 {compiled try with exception (break) in handler} { + apply {{} { + for { set i 5 } { $i < 10 } { incr i } { + try { throw FOO bar } trap FOO {} { break } + } + return $i + }} +} {5} +test error-16.16 {compiled try with exception (continue) in handler} { + apply {{} { + for { set i 5 } { $i < 10 } { incr i } { + try { throw FOO bar } trap FOO {} { continue } + incr i 20 + } + return $i + }} +} {10} +test error-16.17 {compiled try with variable assignment and propagation #1} { + # Ensure that the handler variables preserve the exception off the + # try-body, and are not modified by the exception off the handler + apply {{} { + catch { + try { throw FOO bar } trap FOO {em} { throw BAR baz } + } + return $em + }} +} {bar} +test error-16.18 {compiled try with variable assignment and propagation #2} { + apply {{} { + catch { + try { throw FOO bar } trap FOO {em opts} { throw BAR baz } + } + list $em [dict get $opts -errorcode] + }} +} {bar FOO} +test error-16.19 {compiled try exception chaining (try=ok, handler=error)} -body { + #FIXME is the intent of this test correct? + apply {{} { + catch { + try { list a b c } on ok {em opts} { throw BAR baz } + } tryem tryopts + list $opts [dict get $tryopts -during] + }} +} -match pairwise -result equal +test error-16.20 {compiled try exception chaining (try=error, handler=error)} -body { + # The exception off the handler should chain to the exception off the + # try-body (using the -during option) + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { throw BAR baz } + } tryem tryopts + list $opts [dict get $tryopts -during] + }} +} -match pairwise -result equal +test error-16.21 {compiled try exception chaining (try=error, finally=error)} { + # The exception off the handler should chain to the exception off the + # try-body (using the -during option) + apply {{} { + catch { + try { throw FOO bar } finally { throw BAR baz } + } tryem tryopts + dict get $tryopts -during -errorcode + }} +} FOO +test error-16.22 {compiled try: no exception chaining when handler is successful} { + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { list d e f } + } tryem tryopts + dict exists $tryopts -during + }} +} {0} +test error-16.23 {compiled try: no exception chaining when handler is a non-error exception} { + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { break } + } tryem tryopts + dict exists $tryopts -during + }} +} {0} +test error-16.24 {compiled try exception chaining (try=ok, handler=error, finally=error)} -body { + apply {{} { + catch { + try { + list a b c + } on ok {em opts} { + throw BAR baz + } finally { + throw DING dong + } + } tryem tryopts + list $opts [dict get $tryopts -during -during] + }} +} -match pairwise -result equal +test error-16.25 {compiled try exception chaining (all errors)} -body { + apply {{} { + catch { + try { + throw FOO bar + } on error {em opts} { + throw BAR baz + } finally { + throw DING dong + } + } tryem tryopts + list $opts [dict get $tryopts -during -during] + }} +} -match pairwise -result equal # try tests - finally @@ -709,15 +853,15 @@ test error-18.5 {exception in finally doesn't affect variable assignment} { } list $em [dict get $opts -errorcode] } {bar FOO} -test error-18.6 {exception chaining in finally (try=ok)} { +test error-18.6 {exception chaining in finally (try=ok)} -body { catch { list a b c } em expopts catch { try { list a b c } finally { throw BAR foo } } em opts - string equal $expopts [dict get $opts -during] -} {1} + list $expopts [dict get $opts -during] +} -match pairwise -result equal test error-18.7 {exception chaining in finally (try=error)} { catch { try { throw FOO bar } finally { throw BAR baz } diff --git a/tests/exec.test b/tests/exec.test index 64d3517..871c0c5 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -157,7 +157,7 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup { encoding system iso8859-1 proc quotenonascii s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all {[\u007f-\uffff]} $s \ + regsub -all "\[\u007f-\uffff\]" $s \ {[apply {c {format {\u%04x} [scan $c %c]}} &]} s return [subst -novariables $s] } diff --git a/tests/expr-old.test b/tests/expr-old.test index 4f3cb2e..06a00ba 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -13,10 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 - namespace import -force ::tcltest::* -} +package require tcltest 2.1 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -145,7 +143,7 @@ test expr-old-1.50 {integer operators} {expr +36} 36 test expr-old-1.51 {integer operators} {expr +--++36} 36 test expr-old-1.52 {integer operators} {expr +36%+5} 1 test expr-old-1.53 {integer operators} { - catch {unset x} + unset -nocomplain x set x yes list [expr {1 && $x}] [expr {$x && 1}] \ [expr {0 || $x}] [expr {$x || 0}] @@ -453,7 +451,7 @@ test expr-old-23.3 {double quotes} { test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22 test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc} test expr-old-23.6 {double quotes} { - catch {unset bogus__} + unset -nocomplain bogus__ list [catch {expr {"$bogus__"}} msg] $msg } {1 {can't read "bogus__": no such variable}} test expr-old-23.7 {double quotes} { @@ -502,7 +500,7 @@ test expr-old-26.2 {error conditions} -body { test expr-old-26.3 {error conditions} -body { expr 2+4*( } -returnCodes error -match glob -result * -catch {unset _non_existent_} +unset -nocomplain _non_existent_ test expr-old-26.4 {error conditions} { list [catch {expr 2+$_non_existent_} msg] $msg } {1 {can't read "_non_existent_": no such variable}} @@ -581,7 +579,7 @@ test expr-old-27.4 {cancelled evaluation} { expr {1?2:[set a 2]} set a } 1 -catch {unset x} +unset -nocomplain x test expr-old-27.5 {cancelled evaluation} { list [catch {expr {[info exists x] && $x}} msg] $msg } {0 0} diff --git a/tests/fCmd.test b/tests/fCmd.test index 325b374..8f27ad4 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -2441,14 +2441,17 @@ test fCmd-28.12 {file link: cd into a link} -setup { return "ok" } } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result ok test fCmd-28.13 {file link} -constraints {linkDirectory} -setup { cd [temporaryDirectory] + file link abc.link abc.dir } -body { # duplicate link throws error file link abc.link abc.dir } -returnCodes error -cleanup { + file delete -force abc.link cd [workingDirectory] } -result {could not create new link "abc.link": that path already exists} test fCmd-28.14 {file link: deletes link not dir} -setup { @@ -2469,6 +2472,7 @@ test fCmd-28.15.1 {file link: copies link not dir} -setup { # directory, not a link (links trace to endpoint). list [file type abc2.link] [file tail [file link abc.link]] } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result {directory abc.dir} test fCmd-28.15.2 {file link: copies link not dir} -setup { @@ -2479,6 +2483,7 @@ test fCmd-28.15.2 {file link: copies link not dir} -setup { file copy abc.link abc2.link list [file type abc2.link] [file tail [file link abc2.link]] } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result {link abc.dir} cd [temporaryDirectory] @@ -2498,20 +2503,25 @@ test fCmd-28.16 {file link: glob inside link} -setup { file link abc.link abc.dir lsort [glob -dir abc.link -tails *] } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result {abc.file abc2.file} test fCmd-28.17 {file link: glob -type l} -setup { cd [temporaryDirectory] + file link abc.link abc.dir } -constraints {linkDirectory} -body { glob -dir [pwd] -type l -tails abc* } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result {abc.link} test fCmd-28.18 {file link: glob -type d} -constraints linkDirectory -setup { cd [temporaryDirectory] + file link abc.link abc.dir } -body { lsort [glob -dir [pwd] -type d -tails abc*] } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result [lsort [list abc.link abc.dir abc2.dir]] test fCmd-28.19 {file link: relative paths} -setup { diff --git a/tests/fileSystem.test b/tests/fileSystem.test index b098f35..942a86c 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -138,13 +138,18 @@ test filesystem-1.9 {link normalisation} -setup { testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ [file normalize [file join dir.link inside.file foo]] } -result ok -test filesystem-1.10 {link normalisation: double link} {unix hasLinks} { +test filesystem-1.10 {link normalisation: double link} -constraints { + unix hasLinks +} -body { file link dir2.link dir.link testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ [file normalize [file join dir2.link inside.file foo]] -} ok +} -cleanup { + file delete dir2.link +} -result ok makeDirectory dir2.file test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} { + file link dir2.link dir.link file link [file join dir2.file dir2.link] [file join .. dir2.link] testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ [file normalize [file join dir2.file dir2.link inside.file foo]] @@ -373,7 +378,9 @@ test filesystem-2.0 {new native path} {unix} { # Make sure the testfilesystem hasn't been registered. if {[testConstraint testfilesystem]} { + proc resetfs {} { while {![catch {testfilesystem 0}]} {} + } } test filesystem-3.1 {Tcl_FSRegister & Tcl_FSUnregister} testfilesystem { @@ -388,12 +395,14 @@ test filesystem-3.3 {Tcl_FSRegister} testfilesystem { testfilesystem 0 testfilesystem 0 } {unregistered} -test filesystem-3.4 {Tcl_FSRegister} testfilesystem { +test filesystem-3.4 {Tcl_FSRegister} -constraints testfilesystem -body { testfilesystem 1 file system bar -} {reporting} -test filesystem-3.5 {Tcl_FSUnregister} testfilesystem { +} -cleanup { testfilesystem 0 +} -result {reporting} +test filesystem-3.5 {Tcl_FSUnregister} testfilesystem { + resetfs lindex [file system bar] 0 } {native} @@ -632,7 +641,7 @@ test filesystem-7.4 {cross-filesystem file copy with -force} -setup { file delete -force simplefile file delete -force file2 cd $dir -} -result {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1} +} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1} test filesystem-7.5 {cross-filesystem file copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] @@ -657,7 +666,7 @@ test filesystem-7.5 {cross-filesystem file copy with -force} -setup { file delete -force simplefile file delete -force file2 cd $dir -} -result {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1} +} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1} test filesystem-7.6 {cross-filesystem dir copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] diff --git a/tests/for.test b/tests/for.test index ff4dc0e..8abd270 100644 --- a/tests/for.test +++ b/tests/for.test @@ -14,6 +14,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +# Used for constraining memory leak tests +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc meminfo {} {lindex [split [memory info] "\n"] 3 3} +} + # Basic "for" operation. test for-1.1 {TclCompileForCmd: missing initial command} { @@ -345,7 +351,6 @@ proc formatMail {} { 64 { UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \ 65 { binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \ } - set result "" set NL " " @@ -365,7 +370,6 @@ proc formatMail {} { } else { set break 1 } - set xmailer 0 set inheaders 1 set last [array size lines] @@ -386,9 +390,7 @@ proc formatMail {} { set limit 55 } else { set limit 55 - # Decide whether or not to break the body line - if {$plen > 0} { if {[string first {> } $line] == 0} { # This is quoted text from previous message, don't reformat @@ -431,7 +433,7 @@ proc formatMail {} { set climit [expr $limit-1] set cutoff 50 set continuation 0 - + while {[string length $line] > $limit} { for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} { set char [string index $line $c] @@ -824,7 +826,369 @@ test for-6.18 {Tcl_ForObjCmd: for command result} { 1 {invoked "continue" outside of a loop} \ ] - +test for-7.1 {Bug 3614226: ensure that break cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [break] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.2 {Bug 3614226: ensure that continue cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [continue] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[break] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[continue] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.5 {Bug 3614226: ensure that break cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.6 {Bug 3614226: ensure that continue cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.7 {Bug 3614226: ensure that break only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.8 {Bug 3614226: ensure that continue only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.9 {Bug 3614226: ensure that break from invoked command cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [apply {{} {return -code break}}] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.10 {Bug 3614226: ensure that continue from invoked command cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [apply {{} {return -code continue}}] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.11 {Bug 3614226: ensure that break from invoked command cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[apply {{} {return -code break}}] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.12 {Bug 3614226: ensure that continue from invoked command cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[apply {{} { + return -code continue + }}] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.13 {Bug 3614226: ensure that break from invoked command cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code break + }}] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.14 {Bug 3614226: ensure that continue from invoked command cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code continue + }}] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.15 {Bug 3614226: ensure that break from invoked command only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code break + }}] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.16 {Bug 3614226: ensure that continue from invoked command only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code continue + }}] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.17 {Bug 3614226: ensure that break from expanded command cleans up the stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [{*}$op] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.18 {Bug 3614226: ensure that continue from expanded command cleans up the stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [{*}$op] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.19 {Bug 3614226: ensure that break from expanded command cleans up the expansion stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[{*}$op] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.20 {Bug 3614226: ensure that continue from expanded command cleans up the expansion stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[{*}$op] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.21 {Bug 3614226: ensure that break from expanded command cleans up the combination of main and expansion stack} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.22 {Bug 3614226: ensure that continue from expanded command cleans up the combination of main and expansion stack} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.23 {Bug 3614226: ensure that break from expanded command only cleans up the right amount} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.24 {Bug 3614226: ensure that continue from expanded command only cleans up the right amount} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/foreach.test b/tests/foreach.test index 6c69b29..6fd5476 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -254,6 +254,17 @@ test foreach-9.1 {compiled empty var list} { list [catch { foo } msg] $msg } {1 {foreach varlist is empty}} +test foreach-9.2 {line numbers} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + foreach x y {*}{ + } {return [incr n -[linenumber]]} + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + test foreach-10.1 {foreach: [Bug 1671087]} -setup { proc demo {} { set vals {1 2 3 4} diff --git a/tests/http.test b/tests/http.test index 9861e0e..a52cfb1 100644 --- a/tests/http.test +++ b/tests/http.test @@ -119,7 +119,7 @@ test http-3.2 {http::geturl} -returnCodes error -body { http::geturl http:junk } -result {Unsupported URL: http:junk} set url //[info hostname]:$port -set badurl //[info hostname]:6666 +set badurl //[info hostname]:[expr $port+1] test http-3.3 {http::geturl} -body { set token [http::geturl $url] http::data $token @@ -131,10 +131,11 @@ test http-3.3 {http::geturl} -body { </body></html>" set tail /a/b/c set url //[info hostname]:$port/a/b/c -set fullurl http://user:pass@[info hostname]:$port/a/b/c +set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c set binurl //[info hostname]:$port/binary set posturl //[info hostname]:$port/post set badposturl //[info hostname]:$port/droppost +set authorityurl //[info hostname]:$port set ipv6url http://\[::1\]:$port/ test http-3.4 {http::geturl} -body { set token [http::geturl $url] @@ -391,7 +392,7 @@ Connection close Content-Type {text/plain;charset=utf-8} Accept-Encoding .* Content-Length 5} -test http-3.29 "http::geturl $ipv6url" -body { +test http-3.29 {http::geturl IPv6 address} -body { # We only want to see if the URL gets parsed correctly. This is # the case if http::geturl succeeds or returns a socket related # error. If the parsing is wrong, we'll get a parse error. @@ -405,7 +406,18 @@ test http-3.29 "http::geturl $ipv6url" -body { } -cleanup { catch { http::cleanup $token } } -result 0 - +test http-3.30 {http::geturl query without path} -body { + set token [http::geturl $authorityurl?var=val] + http::ncode $token +} -cleanup { + catch { http::cleanup $token } +} -result 200 +test http-3.31 {http::geturl fragment without path} -body { + set token [http::geturl "$authorityurl#fragment42"] + http::ncode $token +} -cleanup { + catch { http::cleanup $token } +} -result 200 test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] upvar #0 $token data @@ -547,11 +559,10 @@ test http-4.14 {http::Event} -body { error "bogus return from http::geturl" } http::wait $token - http::status $token - # error code varies among platforms. -} -returnCodes 1 -match regexp -cleanup { + lindex [http::error $token] 0 +} -cleanup { catch {http::cleanup $token} -} -result {(connect failed|couldn't open socket)} +} -result {connect failed connection refused} # Bogus host test http-4.15 {http::Event} -body { # This test may fail if you use a proxy server. That is to be diff --git a/tests/httpd b/tests/httpd index f810797..232e80a 100644 --- a/tests/httpd +++ b/tests/httpd @@ -40,7 +40,7 @@ proc httpdAccept {newsock ipaddr port} { fconfigure $newsock -blocking 0 -translation {auto crlf} httpd_log $newsock Connect $ipaddr $port set data(ipaddr) $ipaddr - fileevent $newsock readable [list httpdRead $newsock] + after 50 [list fileevent $newsock readable [list httpdRead $newsock]] } # read data from a client request diff --git a/tests/info.test b/tests/info.test index ebc853a..3057dd2 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1962,6 +1962,440 @@ test info-9.13 {info level option, value in global context} -body { } -returnCodes error -result {bad level "2"} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + catch {*}{ + {info frame 0} + res + } + return $res +} +test info-33.4 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + dict for {a b} {c d} {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.5 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {a b} + dict update d x y {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.6 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {} + dict with d {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.7 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {set res [info frame 0]} + {1} {} {break} + } + return $res +} +test info-33.8 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} {} + {set res [info frame 0]; break} + } + return $res +} +test info-33.9 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} + {return [info frame 0]} + {} + } +} +test info-33.10 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} + {[return [info frame 0]]} + {} {} + } +} +test info-33.11 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x + } [return [info frame 0]] {} +} +test info-33.12 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x y + {set res [info frame 0]} + } + return $res +} +test info-33.13 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if {*}{ + {[return [info frame 0]]} + {} + } +} +test info-33.14 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if 0 {*}{ + {} else + {return [info frame 0]} + } +} +test info-33.15 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + incr {*}{ + x + } [return [info frame 0]] +} +test info-33.16 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + info level {*}{ + } [return [info frame 0]] +} +test info-33.17 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + } [return [info frame 0]] {} +} +test info-33.18 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + {} + } [return [info frame 0]] +} +test info-33.19 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string length {*}{ + } [return [info frame 0]] +} +test info-33.20 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while {*}{ + {[return [info frame 0]]} + } {} +} +test info-33.21 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + switch -- {*}{ + } [return [info frame 0]] {*}{ + } x y +} +test info-33.22 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.23 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } finally {} + return $res +} +test info-33.24 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} + return $res +} +test info-33.25 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} finally {} + return $res +} +test info-33.26 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while 1 {*}{ + {return [info frame 0]} + } +} +test info-33.27 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.28 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.29 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } +} +test info-33.30 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } finally {} +} +test info-33.31 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + binary format {*}{ + } [return [info frame 0]] +} +test info-33.32 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set format format + binary $format {*}{ + } [return [info frame 0]] +} +test info-33.33 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append x {*}{ + } [return [info frame 0]] +} +test info-33.34 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append {*}{ + } x([return [info frame 0]]) {*}{ + } a +} +test info-33.35 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup diff --git a/tests/interp.test b/tests/interp.test index 0af9887..ad99fac 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -1599,6 +1599,20 @@ test interp-20.50 {Bug 2486550} -setup { } -cleanup { interp delete slave } -returnCodes error -match glob -result * +test interp-20.50.1 {Bug 2486550} -setup { + interp create slave +} -body { + slave hide coroutine + catch {slave invokehidden coroutine} m o + dict get $o -errorinfo +} -cleanup { + unset -nocomplain m 0 + interp delete slave +} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" + while executing +"coroutine" + invoked from within +"slave invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} diff --git a/tests/listObj.test b/tests/listObj.test index 937fb1d..d7fb46c 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -196,7 +196,7 @@ test listobj-10.1 {Bug [2971669]} {*}{ -result {{a b c d e} {} {a b c d e f}} } -test listobj-11.1 {bug 3598580} { +test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj { testobj bug3598580 } 123 diff --git a/tests/lmap.test b/tests/lmap.test index 7baa77b..08035d9 100644 --- a/tests/lmap.test +++ b/tests/lmap.test @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -unset -nocomplain a i x +unset -nocomplain a b i x # ----- Non-compiled operation ----------------------------------------------- @@ -404,14 +404,21 @@ test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup { rename demo {} } -result {2 4} # Huge lists must not overflow the bytecode interpreter (development bug) -test lmap-7.7 {huge list non-compiled} { +test lmap-7.7 {huge list non-compiled} -setup { + unset -nocomplain a b x +} -body { set x [lmap a [lrepeat 1000000 x] { set b y$a }] list $b [llength $x] [string length $x] -} {yx 1000000 2999999} -test lmap-7.8 {huge list compiled} { - set x [apply {{times} { lmap a [lrepeat $times x] { set b y$a }}} 1000000] +} -result {yx 1000000 2999999} +test lmap-7.8 {huge list compiled} -setup { + unset -nocomplain a b x +} -body { + set x [apply {{times} { + global b + lmap a [lrepeat $times x] { set b Y$a } + }} 1000000] list $b [llength $x] [string length $x] -} {yx 1000000 2999999} +} -result {Yx 1000000 2999999} test lmap-7.9 {error then dereference loop var (dev bug)} { catch { lmap a 0 b {1 2 3} { error x } } set a diff --git a/tests/load.test b/tests/load.test index cded85d..9536271 100644 --- a/tests/load.test +++ b/tests/load.test @@ -215,6 +215,12 @@ test load-10.1 {load from vfs} \ -body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \ -result {0 {}} \ -cleanup {testsimplefilesystem 0; cd $dir; unset dir} + +test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ + [list $dll $loaded] { + load [file join $testDir pkgooa$ext] + list [pkgooa_stubsok] [lsort [info commands pkgooa_*]] +} {1 pkgooa_stubsok} # cleanup unset ext diff --git a/tests/main.test b/tests/main.test index f1dc7fd..351fd4f 100644 --- a/tests/main.test +++ b/tests/main.test @@ -129,7 +129,7 @@ namespace eval ::tcl::test::main { set script [makeFile {} script] file delete $script set f [open $script w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" @@ -150,7 +150,7 @@ namespace eval ::tcl::test::main { set script [makeFile {} script] file delete $script set f [open $script w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" @@ -171,7 +171,7 @@ namespace eval ::tcl::test::main { set script [makeFile {} script] file delete $script set f [open $script w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" @@ -592,7 +592,7 @@ namespace eval ::tcl::test::main { catch {set f [open "|[list [interpreter]]" w+]} } -body { type $f { - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 puts SUCCESS } list [catch {gets $f} line] $line @@ -606,19 +606,19 @@ namespace eval ::tcl::test::main { exec } -setup { catch {set f [open "|[list [interpreter]]" w+]} - catch {fconfigure $f -blocking 0} + catch {chan configure $f -blocking 0} } -body { - type $f "fconfigure stdin -eofchar \\032 + type $f "chan configure stdin -eofchar \\032 if 1 \{\n\032" variable wait - fileevent $f readable \ + chan event $f readable \ [list set [namespace which -variable wait] "child exit"] set id [after 2000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait } -cleanup { - if {[string equal timeout $wait] && [testConstraint unix]} { + if {$wait eq "timeout" && [testConstraint unix]} { exec kill [pid $f] } close $f @@ -631,17 +631,17 @@ namespace eval ::tcl::test::main { } -setup { set cmd {makeFile "if 1 \{" script} catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]} - catch {fconfigure $f -blocking 0} + catch {chan configure $f -blocking 0} } -body { variable wait - fileevent $f readable \ + chan event $f readable \ [list set [namespace which -variable wait] "child exit"] set id [after 2000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait } -cleanup { - if {[string equal timeout $wait] && [testConstraint unix]} { + if {$wait eq "timeout" && [testConstraint unix]} { exec kill [pid $f] } close $f @@ -748,7 +748,7 @@ namespace eval ::tcl::test::main { exec Tcltest } -setup { catch {set f [open "|[list [interpreter]]" w+]} - catch {fconfigure $f -blocking 0} + catch {chan configure $f -blocking 0} } -body { type $f "testsetmainloop after 2000 testexitmainloop @@ -983,7 +983,7 @@ namespace eval ::tcl::test::main { } -body { exec [interpreter] << { testsetmainloop - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 testexitmainloop } >& result set f [open result] diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..d4ece74 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} { missing close-brace for variable name missing close-brace for variable name while executing -"set tst $a([winfo name $\{zz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." +"set tst $a([winfo name $\{" (procedure "tstProc" line 4) invoked from within "tstProc"}] diff --git a/tests/msgcat.test b/tests/msgcat.test index 1522354..050b592 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -12,13 +12,13 @@ # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. -package require Tcl 8.2 +package require Tcl 8.5 if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } -if {[catch {package require msgcat 1.5.0}]} { - puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test." +if {[catch {package require msgcat 1.5}]} { + puts stderr "Skipping tests in [info script]. No msgcat 1.5 found to test." return } @@ -56,7 +56,7 @@ namespace eval ::msgcat::test { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } else { - if {([info sharedlibextension] == ".dll") + if {([info sharedlibextension] eq ".dll") && ![catch {package require registry}]} { # Windows and Cygwin have other ways to determine the # locale when the environment variables are missing @@ -72,7 +72,7 @@ namespace eval ::msgcat::test { variable var foreach var $envVars { catch {variable $var $::env($var)} - catch {unset ::env($var)} + unset -nocomplain ::env($var) } foreach var $setVars { set ::env($var) $var @@ -84,13 +84,13 @@ namespace eval ::msgcat::test { } -cleanup { interp delete [namespace current]::i foreach var $envVars { - catch {unset ::env($var)} + unset -nocomplain ::env($var) catch {set ::env($var) [set [namespace current]::$var]} } } -body {i eval msgcat::mclocale} -result $result incr count } - catch {unset result} + unset -nocomplain result # Could add tests of initialization from Windows registry here. # Use a fake registry package. @@ -324,7 +324,7 @@ namespace eval ::msgcat::test { incr count } } - catch {unset result} + unset -nocomplain result # Tests msgcat-4.*: [mcunknown] diff --git a/tests/namespace.test b/tests/namespace.test index 1d46bf0..f6688f1 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1111,6 +1111,14 @@ test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { } list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello] } [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}] +test namespace-26.8 {NamespaceExportCmd, -clear resets export list} { + catch {namespace delete foo} + namespace eval foo { + namespace export x + namespace export -clear + } + list [namespace eval foo namespace export] [namespace delete foo] +} {{} {}} test namespace-27.1 {NamespaceForgetCmd, no args} { catch {namespace delete {*}[namespace children :: test_ns_*]} diff --git a/tests/oo.test b/tests/oo.test index 5d34077..d63e931 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,12 +2,12 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2012 Donal K. Fellows +# Copyright (c) 2006-2013 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* @@ -101,7 +101,7 @@ test oo-0.8 {leak in variable management} -setup { test oo-0.9 {various types of presence of the TclOO package} { list [lsearch -nocase -all -inline [package names] tcloo] \ [package present TclOO] [package versions TclOO] -} [list TclOO $::oo::version $::oo::version] +} [list TclOO $::oo::patchlevel $::oo::patchlevel] test oo-1.1 {basic test of OO functionality: no classes} { set result {} @@ -936,6 +936,69 @@ test oo-6.18 {Bug 3408830: more forwarding cases} -setup { } -returnCodes error -cleanup { fooClass destroy } -result {wrong # args: should be "::foo len string"} +test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup { + oo::object create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::objdefine foo { + method target {} {lappend ::result instance} + forward bar my target + method bump {} { + set ns [info object namespace ::foo] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + foo destroy +} -result {instance instance instance instance instance instance} +test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup { + oo::class create fooClass + fooClass create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::define fooClass { + method target {} {lappend ::result class} + forward bar my target + method bump {} { + set ns [info object namespace [self]] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + fooClass destroy +} -result {class class class class class class} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass @@ -1776,6 +1839,36 @@ test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup { } -returnCodes error -cleanup { Foo destroy } -result {wrong # args: should be "::bar <cloned> a b"} +test oo-15.10 {variable binding must not bleed through oo::copy} -setup { + oo::class create FooClass + set result {} +} -body { + set obj1 [FooClass new] + oo::objdefine $obj1 { + variable var + method m {} { + set var foo + } + method get {} { + return $var + } + export eval + } + + $obj1 m + lappend result [$obj1 get] + set obj2 [oo::copy $obj1] + $obj2 eval { + set var bar + } + lappend result [$obj2 get] + $obj1 eval { + set var grill + } + lappend result [$obj1 get] [$obj2 get] +} -cleanup { + FooClass destroy +} -result {foo bar grill bar} test oo-16.1 {OO: object introspection} -body { info object @@ -2204,6 +2297,25 @@ test oo-19.2 {OO: varname method: Bug 2883857} -setup { } -cleanup { SpecialClass destroy } -result ::oo_test::x(y) +test oo-19.3 {OO: varname method and variable decl: Bug 3603695} -setup { + oo::class create testClass { + variable foo + export varname + constructor {} { + variable foo x + } + method bar {obj} { + my varname foo + $obj varname foo + } + } +} -body { + testClass create A + testClass create B + lsearch [list [A varname foo] [B varname foo]] [B bar A] +} -cleanup { + testClass destroy +} -result 0 test oo-20.1 {OO: variable method} -body { oo::class create testClass { @@ -3355,6 +3467,42 @@ test oo-34.8 {TIP 380: slots - presence} { test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -clear -set} {Get Set}} + +test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { + oo::class create fruit { + method eat {} {} + } + set result {} +} -body { + lappend result [fruit create ::apple] [info class superclasses fruit] + oo::define fruit superclass + lappend result [info class superclasses fruit] \ + [info object class apple oo::object] \ + [info class call fruit destroy] \ + [catch { apple }] +} -cleanup { + unset -nocomplain result + fruit destroy +} -result {::apple ::oo::object ::oo::object 1 {{method destroy ::oo::object {core method: "destroy"}}} 1} +test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { + oo::class create fruitMetaclass { + superclass oo::class + method eat {} {} + } + set result {} +} -body { + lappend result [fruitMetaclass create ::appleClass] \ + [appleClass create orange] \ + [info class superclasses fruitMetaclass] + oo::define fruitMetaclass superclass + lappend result [info class superclasses fruitMetaclass] \ + [info object class appleClass oo::class] \ + [catch { orange }] [info object class orange] \ + [appleClass create pear] +} -cleanup { + unset -nocomplain result + fruitMetaclass destroy +} -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear} cleanupTests return diff --git a/tests/ooNext2.test b/tests/ooNext2.test index d77e8d1..a47aa91 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/parse.test b/tests/parse.test index 0f76d64..01443c9 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -26,6 +26,8 @@ testConstraint testparsevarname [llength [info commands testparsevarname]] testConstraint testparsevar [llength [info commands testparsevar]] testConstraint testasync [llength [info commands testasync]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] +testConstraint testevent [llength [info commands testevent]] +testConstraint memory [llength [info commands memory]] test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -438,7 +440,7 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} { test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex { - catch {unset x} + unset -nocomplain x list [catch {testevalex {for {} 1 {} { @@ -479,7 +481,7 @@ test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex { testevalex {concat [expr 2 + 6]} } {8} test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat xxx[expr $a]}} msg] $msg } {1 {can't read "a": no such variable}} test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex { @@ -487,21 +489,21 @@ test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex { testevalex {concat $a} } {hello} test parse-10.6 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a set a(12) 46 testevalex {concat $a(12)} } {46} test parse-10.7 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a set a(12) 46 testevalex {concat $a(1[expr 3 - 1])} } {46} test parse-10.8 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat $x($a)}} msg] $msg } {1 {can't read "a": no such variable}} test parse-10.9 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat xyz$a(1)}} msg] $msg } {1 {can't read "a(1)": no such variable}} test parse-10.10 {Tcl_EvalTokens, object values} testevalex { @@ -541,11 +543,11 @@ test parse-11.2 {Tcl_EvalEx, error while parsing} testevalex { list [catch {testevalex {concat "abc}} msg] $msg } {1 {missing "}} test parse-11.3 {Tcl_EvalEx, error while collecting words} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat xyz $a}} msg] $msg } {1 {can't read "a": no such variable}} test parse-11.4 {Tcl_EvalEx, error in Tcl_EvalObjv call} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {_bogus_ a b c d}} msg] $msg } {1 {invalid command name "_bogus_"}} test parse-11.5 {Tcl_EvalEx, exceptional return} testevalex { @@ -564,7 +566,7 @@ test parse-11.8 {Tcl_EvalEx, multiple commands in script} testevalex { }] $a $c } {d b d} test parse-11.9 {Tcl_EvalEx, freeing memory after error} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z $a}} msg] $msg } {1 {can't read "a": no such variable}} test parse-11.10 {Tcl_EvalTokens, empty commands} testevalex { @@ -670,13 +672,33 @@ test parse-13.3 {Tcl_ParseVar procedure, no variable name} testparsevar { testparsevar {$.123} } {{$} .123} test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} testparsevar { - catch {unset abc} + unset -nocomplain abc list [catch {testparsevar {$abc}} msg] $msg } {1 {can't read "abc": no such variable}} test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar { - catch {unset abc} + unset -nocomplain abc list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} +test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup { + proc getbytes {} { + return [lindex [split [memory info] \n] 3 3] + } +} -body { + set a() foo + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set vn {} + set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]] + if {$res ne {foo bar}} {error "Unexpected result: $res"} + + set tmp $end + set end [getbytes] + } + expr {$end - $tmp} +} -cleanup { + unset -nocomplain a end i vn res tmp + rename getbytes {} +} -result 0 test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -1090,6 +1112,19 @@ test parse-20.12 {TclParseBackslash: truncated escape} testparser { testparser {\x12X} 5 } {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}} +test parse-21.0 {Bug 1884496} testevent { + set ::script {testevent delete a; set a [p]; set ::done $a} + proc ::p {} {string first s $::script} + testevent queue a head $::script + vwait done +} {} +test parse-21.1 {TCL_EVAL_DIRECT coverage} testevent { + testevent queue a head {testevent delete a; \ + set ::done [dict get [info frame 0] line]} + vwait done + set ::done +} 2 + cleanupTests } diff --git a/tests/parseExpr.test b/tests/parseExpr.test index 7910974..714c45b 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -8,10 +8,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -1067,5 +1065,5 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body { # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/parseOld.test b/tests/parseOld.test index 0edcbf0..f3b1591 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -13,10 +13,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -166,25 +164,25 @@ test parseOld-5.6 {variable substitution} { set msg } {can't read "_non_existent_": no such variable} test parseOld-5.7 {array variable substitution} { - catch {unset a} + unset -nocomplain a set a(xyz) 123 set b $a(xyz)foo set b } 123foo test parseOld-5.8 {array variable substitution} { - catch {unset a} + unset -nocomplain a set "a(x y z)" 123 set b $a(x y z)foo set b } 123foo test parseOld-5.9 {array variable substitution} { - catch {unset a}; catch {unset qqq} + unset -nocomplain a qqq set "a(x y z)" qqq set $a([format x]\ y [format z]) foo set qqq } foo test parseOld-5.10 {array variable substitution} { - catch {unset a} + unset -nocomplain a list [catch {set b $a(22)} msg] $msg } {1 {can't read "a(22)": no such variable}} test parseOld-5.11 {array variable substitution} { @@ -194,9 +192,9 @@ test parseOld-5.11 {array variable substitution} { test parseOld-5.12 {empty array name support} { list [catch {set b a$()} msg] $msg } {1 {can't read "()": no such variable}} -catch {unset a} +unset -nocomplain a test parseOld-5.13 {array variable substitution} { - catch {unset a} + unset -nocomplain a set long {This is a very long variable, long enough to cause storage \ allocation to occur in Tcl_ParseVar. If that storage isn't getting \ freed up correctly, then a core leak will occur when this test is \ @@ -211,13 +209,13 @@ test parseOld-5.13 {array variable substitution} { run. This text is probably beginning to sound like drivel, but I've \ run out of things to say and I need more characters still.}}} test parseOld-5.14 {array variable substitution} { - catch {unset a}; catch {unset b}; catch {unset a1} + unset -nocomplain a b a1 set a1(22) foo set a(foo) bar set b $a($a1(22)) set b } bar -catch {unset a}; catch {unset a1} +unset -nocomplain a a1 test parseOld-7.1 {backslash substitution} { set a "\a\c\n\]\}" diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 0fe394e..84c82ce 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -8,10 +8,8 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* set fullPkgPath [makeDirectory pkg] @@ -45,7 +43,7 @@ proc pkgtest::parseArgs { args } { set a [lindex $args $iarg] if {[regexp {^-} $a]} { lappend options $a - if {[string compare -load $a] == 0} { + if {$a eq "-load"} { incr iarg lappend options [lindex $args $iarg] } @@ -81,7 +79,7 @@ proc pkgtest::parseIndex { filePath } { $slave eval { rename package package_original proc package { args } { - if {[string compare [lindex $args 0] ifneeded] == 0} { + if {[lindex $args 0] eq "ifneeded"} { set pkg [lindex $args 1] set ver [lindex $args 2] set ::PKGS($pkg:$ver) [lindex $args 3] @@ -111,9 +109,9 @@ proc pkgtest::parseIndex { filePath } { foreach k [lsort [array names P]] { lappend PKGS $k $P($k) } - } err]} { - set ei $::errorInfo - set ec $::errorCode + } err opts]} { + set ei [dict get $opts -errorinfo] + set ec [dict get $opts -errorcode] catch {interp delete $slave} diff --git a/tests/platform.test b/tests/platform.test index aab7c78..6596975 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -9,10 +9,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2 + +namespace eval ::tcl::test::platform { + namespace import ::tcltest::testConstraint + namespace import ::tcltest::test + namespace import ::tcltest::cleanupTests + + variable ::tcl_platform ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -54,7 +58,10 @@ test platform-3.1 {CPU ID on Windows/UNIX} \ -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$} # cleanup -::tcltest::cleanupTests +cleanupTests + +} +namespace delete ::tcl::test::platform return # Local Variables: diff --git a/tests/reg.test b/tests/reg.test index a0ea850..e6ce42c 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -1080,6 +1080,84 @@ test reg-33.13 {Bug 1810264 - infinite loop} { test reg-33.14 {Bug 1810264 - super-expensive expression} nonPortable { regexp {(x{200}){200}$y} {x} } 0 +test reg-33.15 {Bug 3603557 - an "in the wild" RE} { + lindex [regexp -expanded -about { + ^TETRA_MODE_CMD # Message Type + ([[:blank:]]+) # Pad + (ETS_1_1|ETS_1_2|ETS_2_2) # SystemCode + ([[:blank:]]+) # Pad + (CONTINUOUS|CARRIER|MCCH|TRAFFIC) # SharingMode + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # ColourCode + ([[:blank:]]+) # Pad + (1|2|3|4|6|9|12|18) # TSReservedFrames + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # UPlaneDTX + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # Frame18Extension + ([[:blank:]]+) # Pad + ([[:digit:]]{1,4}) # MCC + ([[:blank:]]+) # Pad + ([[:digit:]]{1,5}) # MNC + ([[:blank:]]+) # Pad + (BOTH|BCAST|ENQRY|NONE) # NbrCellBcast + ([[:blank:]]+) # Pad + (UNKNOWN|LOW|MEDIUM|HIGH) # CellServiceLevel + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # LateEntryInfo + ([[:blank:]]+) # Pad + (300|400) # FrequencyBand + ([[:blank:]]+) # Pad + (NORMAL|REVERSE) # ReverseOperation + ([[:blank:]]+) # Pad + (NONE|\+6\.25|\-6\.25|\+12\.5) # Offset + ([[:blank:]]+) # Pad + (10) # DuplexSpacing + ([[:blank:]]+) # Pad + ([[:digit:]]{1,4}) # MainCarrierNr + ([[:blank:]]+) # Pad + (0|1|2|3) # NrCSCCH + ([[:blank:]]+) # Pad + (15|20|25|30|35|40|45) # MSTxPwrMax + ([[:blank:]]+) # Pad + (\-125|\-120|\-115|\-110|\-105|\-100|\-95|\-90|\-85|\-80|\-75|\-70|\-65|\-60|\-55|\-50) + # RxLevAccessMin + ([[:blank:]]+) # Pad + (\-53|\-51|\-49|\-47|\-45|\-43|\-41|\-39|\-37|\-35|\-33|\-31|\-29|\-27|\-25|\-23) + # AccessParameter + ([[:blank:]]+) # Pad + (DISABLE|[[:digit:]]{3,4}) # RadioDLTimeout + ([[:blank:]]+) # Pad + (\-[[:digit:]]{2,3}) # RSSIThreshold + ([[:blank:]]+) # Pad + ([[:digit:]]{1,5}) # CCKIdSCKVerNr + ([[:blank:]]+) # Pad + ([[:digit:]]{1,5}) # LocationArea + ([[:blank:]]+) # Pad + ([(1|0)]{16}) # SubscriberClass + ([[:blank:]]+) # Pad + ([(1|0)]{12}) # BSServiceDetails + ([[:blank:]]+) # Pad + (RANDOMIZE|IMMEDIATE|[[:digit:]]{1,2}) # IMM + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # WT + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # Nu + ([[:blank:]]+) # Pad + ([0-1]) # FrameLngFctr + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # TSPtr + ([[:blank:]]+) # Pad + ([0-7]) # MinPriority + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # ExtdSrvcsEnabled + ([[:blank:]]+) # Pad + (.*) # ConditionalFields + }] 0 +} 68 +test reg-33.16 {Bug [8d2c0da36d]- another "in the wild" RE} { + lindex [regexp -about "^MRK:client1: =1339 14HKelly Talisman 10011000 (\[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]*) \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 8 0 8 0 0 0 77 77 1 1 2 0 11 { 1 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 13HC6 My Creator 2 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 31HC7 Slightly offensive name, huh 3 8 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 23HE-mail:kelly@hotbox.com 4 9 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 17Hcompface must die 5 10 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 3HAir 6 12 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 14HPGP public key 7 13 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 16Hkelly@hotbox.com 8 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 12H2 text/plain 9 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 13H2 x-kom/basic 10 33 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H0 11 14 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H3 }\r?"] 0 +} 1 # cleanup ::tcltest::cleanupTests diff --git a/tests/regexp.test b/tests/regexp.test index 7cafd1b..1b2bec9 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -819,6 +819,67 @@ test regexp-22.1 {Bug 1810038} { test regexp-22.2 {regexp compile and backrefs, Bug 1857126} { regexp -- {([bc])\1} bb } 1 +test regexp-22.3 {Bug 3604074} { + # This will hang in interps where the bug is not fixed + regexp ((((((((a)*)*)*)*)*)*)*)* a +} 1 +test regexp-22.4 {Bug 3606139} -setup { + interp alias {} a {} string repeat a +} -body { + # This crashes in interps where the bug is not fixed + regexp [join [list [a 160]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 672]([a 55])[a 669]([a 55])[a 671]([a 55])[a 671]([a 55]) \ + [a 672]([a 55])[a 652]([a 55])[a 672]([a 55])[a 671]([a 55]) \ + [a 671]([a 55])[a 671]([a 55])[a 653]([a 55])[a 672]([a 55]) \ + [a 653]([a 55])[a 672]([a 55])[a 672]([a 55])[a 652]([a 55]) \ + [a 671]([a 55])[a 652]([a 55])[a 652]([a 55])[a 672]([a 55]) \ + [a 672]([a 55])[a 672]([a 55])[a 653]([a 55])[a 671]([a 55]) \ + [a 669]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 650]([a 55])[a 650]([a 55])[a 672]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 672]([a 55]) \ + [a 670]([a 55])[a 671]([a 55])[a 672]([a 55])[a 672]([a 55]) \ + [a 671]([a 55])[a 671]([a 55])[a 672]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 668]([a 55])[a 669]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 710]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 667]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 671]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 710]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 511]] {}] a +} -cleanup { + rename a {} +} -returnCodes 1 -result {couldn't compile regular expression pattern: nfa has too many states} +test regexp-22.5 {Bug 3610026} -setup { + set e {} + set cp 99 + while {$cp < 32864} { + append e [format %c [incr cp]] + } +} -body { + regexp -about $e +} -cleanup { + unset -nocomplain e cp +} -returnCodes error -match glob -result {*too many colors*} +test regexp-22.6 {Bug 6585b21ca8} { + expr {[regexp {(\w).*?\1} Programmer m] ? $m : "<NONE>"} +} rogr + test regexp-23.1 {regexp -all and -line} { set string "" diff --git a/tests/rename.test b/tests/rename.test index 1fa0441..ebf5425 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -140,6 +140,13 @@ test rename-4.7 {reentrancy issues with command deletion and renaming} testdel { if {[info exists env(value)]} { unset env(value) } +test rename-4.8 {Bug a16752c252} testdel { + set x broken + testdel {} foo {set x ok} + proc foo args {} + rename foo {} + return -level 0 $x[unset x] +} ok # Save the unknown procedure which is modified by the following test. diff --git a/tests/result.test b/tests/result.test index 3391ce1..9e8a66b 100644 --- a/tests/result.test +++ b/tests/result.test @@ -10,10 +10,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/safe.test b/tests/safe.test index 4a2792e..859f352 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -425,6 +425,19 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i {load {} Safepkg1}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1" + invoked from within +"interp eval $i {load {} Safepkg1}"} test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { set i [safe::interpCreate -nostatics] interp eval $i {load {} Safepkg1} @@ -444,6 +457,18 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { + set i [safe::interpCreate -nestedloadok] + catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1 x" + invoked from within +"interp eval $i {interp create x; load {} Safepkg1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] @@ -501,6 +526,23 @@ test safe-11.7 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +test safe-11.7.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertfrom} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertfrom ?encoding? data" + while executing +"encoding convertfrom" + invoked from within +"::interp invokehidden interp1 encoding convertfrom" + invoked from within +"encoding convertfrom" + invoked from within +"interp eval $i encoding convertfrom"} test safe-11.8 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -508,6 +550,23 @@ test safe-11.8 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data"} +test safe-11.8.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertto} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertto ?encoding? data" + while executing +"encoding convertto" + invoked from within +"::interp invokehidden interp1 encoding convertto" + invoked from within +"encoding convertto" + invoked from within +"interp eval $i encoding convertto"} test safe-12.1 {glob is restricted [Bug 2906841]} -setup { set i [safe::interpCreate] @@ -715,8 +774,29 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup { lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg } -cleanup { + unset -nocomplain msg interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} +test safe-15.1.1 {safe file ensemble does not surprise code} -setup { + set i [interp create -safe] +} -body { + set result [expr {"file" in [interp hidden $i]}] + lappend result [interp eval $i {tcl::file::split a/b/c}] + lappend result [catch {interp eval $i {tcl::file::isdirectory .}}] + lappend result [interp invokehidden $i file split a/b/c] + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp invokehidden $i file isdirectory .}] + interp expose $i file + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo] +} -cleanup { + unset -nocomplain msg o + interp delete $i +} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file + while executing +"file isdirectory ." + invoked from within +"interp eval $i {file isdirectory .}"}} ### ~ should have no special meaning in paths in safe interpreters test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { diff --git a/tests/scan.test b/tests/scan.test index 97ad5eb..b57b641 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -1,8 +1,8 @@ # Commands covered: scan # -# 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-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -11,14 +11,83 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } +# procedure that returns the range of integers + +proc int_range {} { + for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} { + set MIN_INT [expr { $MIN_INT << 1 }] + } + set MIN_INT [expr {int($MIN_INT)}] + set MAX_INT [expr { ~ $MIN_INT }] + return [list $MIN_INT $MAX_INT] +} + +# Big test for correct ordering of data in [expr] + +proc testIEEE {} { + variable ieeeValues + binary scan [binary format dd -1.0 1.0] c* c + switch -exact -- $c { + {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { + # little endian + binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + ieeeValues(-Infinity) + binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + ieeeValues(-Normal) + binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ + ieeeValues(-Subnormal) + binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ + ieeeValues(-0) + binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+0) + binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ + ieeeValues(+Subnormal) + binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + ieeeValues(+Normal) + binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + ieeeValues(+Infinity) + binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + ieeeValues(NaN) + set ieeeValues(littleEndian) 1 + return 1 + } + {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { + binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Infinity) + binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Normal) + binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Subnormal) + binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-0) + binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+0) + binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Subnormal) + binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Normal) + binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Infinity) + binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(NaN) + set ieeeValues(littleEndian) 0 + return 1 + } + default { + return 0 + } + } +} + +testConstraint ieeeFloatingPoint [testIEEE] testConstraint wideIs64bit \ [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] - + test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x } {1 f} @@ -43,10 +112,11 @@ test scan-1.7 {BuildCharSet, CharInSet} { test scan-1.8 {BuildCharSet, CharInSet} { list [scan def-abc {%[^c-a]} x] $x } {1 def-} -test scan-1.9 {BuildCharSet, CharInSet no match} { - catch {unset x} +test scan-1.9 {BuildCharSet, CharInSet no match} -setup { + unset -nocomplain x +} -body { list [scan {= f} {= %[TF]} x] [info exists x] -} {0 0} +} -result {0 0} test scan-2.1 {ReleaseCharSet} { list [scan abcde {%[abc]} x] $x @@ -55,53 +125,53 @@ test scan-2.2 {ReleaseCharSet} { list [scan abcde {%[a-c]} x] $x } {1 abc} -test scan-3.1 {ValidateFormat} { - list [catch {scan {} {%d%1$d} x} msg] $msg -} {1 {cannot mix "%" and "%n$" conversion specifiers}} -test scan-3.2 {ValidateFormat} { - list [catch {scan {} {%d%1$d} x} msg] $msg -} {1 {cannot mix "%" and "%n$" conversion specifiers}} -test scan-3.3 {ValidateFormat} { - list [catch {scan {} {%2$d%d} x} msg] $msg -} {1 {"%n$" argument index out of range}} +test scan-3.1 {ValidateFormat} -returnCodes error -body { + scan {} {%d%1$d} x +} -result {cannot mix "%" and "%n$" conversion specifiers} +test scan-3.2 {ValidateFormat} -returnCodes error -body { + scan {} {%d%1$d} x +} -result {cannot mix "%" and "%n$" conversion specifiers} +test scan-3.3 {ValidateFormat} -returnCodes error -body { + scan {} {%2$d%d} x +} -result {"%n$" argument index out of range} test scan-3.4 {ValidateFormat} { # degenerate case, before changed from 8.2 to 8.3 list [catch {scan {} %d} msg] $msg } {0 {}} -test scan-3.5 {ValidateFormat} { - list [catch {scan {} {%10c} a} msg] $msg -} {1 {field width may not be specified in %c conversion}} -test scan-3.6 {ValidateFormat} { - list [catch {scan {} {%*1$d} a} msg] $msg -} {1 {bad scan conversion character "$"}} -test scan-3.7 {ValidateFormat} { - list [catch {scan {} {%1$d%1$d} a} msg] $msg -} {1 {variable is assigned by multiple "%n$" conversion specifiers}} -test scan-3.8 {ValidateFormat} { - list [catch {scan {} a x} msg] $msg -} {1 {variable is not assigned by any conversion specifiers}} -test scan-3.9 {ValidateFormat} { - list [catch {scan {} {%2$s} x y} msg] $msg -} {1 {variable is not assigned by any conversion specifiers}} -test scan-3.10 {ValidateFormat} { - list [catch {scan {} {%[a} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-3.11 {ValidateFormat} { - list [catch {scan {} {%[^a} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-3.12 {ValidateFormat} { - list [catch {scan {} {%[]a} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-3.13 {ValidateFormat} { - list [catch {scan {} {%[^]a} x} msg] $msg -} {1 {unmatched [ in format string}} +test scan-3.5 {ValidateFormat} -returnCodes error -body { + scan {} {%10c} a +} -result {field width may not be specified in %c conversion} +test scan-3.6 {ValidateFormat} -returnCodes error -body { + scan {} {%*1$d} a +} -result {bad scan conversion character "$"} +test scan-3.7 {ValidateFormat} -returnCodes error -body { + scan {} {%1$d%1$d} a +} -result {variable is assigned by multiple "%n$" conversion specifiers} +test scan-3.8 {ValidateFormat} -returnCodes error -body { + scan {} a x +} -result {variable is not assigned by any conversion specifiers} +test scan-3.9 {ValidateFormat} -returnCodes error -body { + scan {} {%2$s} x y +} -result {variable is not assigned by any conversion specifiers} +test scan-3.10 {ValidateFormat} -returnCodes error -body { + scan {} {%[a} x +} -result {unmatched [ in format string} +test scan-3.11 {ValidateFormat} -returnCodes error -body { + scan {} {%[^a} x +} -result {unmatched [ in format string} +test scan-3.12 {ValidateFormat} -returnCodes error -body { + scan {} {%[]a} x +} -result {unmatched [ in format string} +test scan-3.13 {ValidateFormat} -returnCodes error -body { + scan {} {%[^]a} x +} -result {unmatched [ in format string} -test scan-4.1 {Tcl_ScanObjCmd, argument checks} { - list [catch {scan} msg] $msg -} {1 {wrong # args: should be "scan string format ?varName ...?"}} -test scan-4.2 {Tcl_ScanObjCmd, argument checks} { - list [catch {scan string} msg] $msg -} {1 {wrong # args: should be "scan string format ?varName ...?"}} +test scan-4.1 {Tcl_ScanObjCmd, argument checks} -returnCodes error -body { + scan +} -result {wrong # args: should be "scan string format ?varName ...?"} +test scan-4.2 {Tcl_ScanObjCmd, argument checks} -returnCodes error -body { + scan string +} -result {wrong # args: should be "scan string format ?varName ...?"} test scan-4.3 {Tcl_ScanObjCmd, argument checks} { # degenerate case, before changed from 8.2 to 8.3 list [catch {scan string format} msg] $msg @@ -191,99 +261,126 @@ test scan-4.29 {Tcl_ScanObjCmd, character scanning} { list [scan {abcdef} {%*c%n} x] $x } {1 1} -test scan-4.30 {Tcl_ScanObjCmd, base-10 integer scanning} { +test scan-4.30 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {1234567890a} {%3d} x] $x -} {1 123} -test scan-4.31 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {1 123} +test scan-4.31 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {1234567890a} {%d} x] $x -} {1 1234567890} -test scan-4.32 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {1 1234567890} +test scan-4.32 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {01234567890a} {%d} x] $x -} {1 1234567890} -test scan-4.33 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {1 1234567890} +test scan-4.33 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {+01234} {%d} x] $x -} {1 1234} -test scan-4.34 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {1 1234} +test scan-4.34 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {-01234} {%d} x] $x -} {1 -1234} -test scan-4.35 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {1 -1234} +test scan-4.35 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {a01234} {%d} x] $x -} {0 {}} -test scan-4.36 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {0 {}} +test scan-4.36 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {0x10} {%d} x] $x -} {1 0} -test scan-4.37 {Tcl_ScanObjCmd, base-8 integer scanning} { +} -result {1 0} +test scan-4.37 {Tcl_ScanObjCmd, base-8 integer scanning} -setup { set x {} +} -body { list [scan {012345678} {%o} x] $x -} {1 342391} -test scan-4.38 {Tcl_ScanObjCmd, base-8 integer scanning} { +} -result {1 342391} +test scan-4.38 {Tcl_ScanObjCmd, base-8 integer scanning} -setup { set x {} +} -body { list [scan {+1238 -1239 123a} {%o%*s%o%*s%o} x y z] $x $y $z -} {3 83 -83 83} -test scan-4.39 {Tcl_ScanObjCmd, base-16 integer scanning} { +} -result {3 83 -83 83} +test scan-4.39 {Tcl_ScanObjCmd, base-16 integer scanning} -setup { set x {} +} -body { list [scan {+1238 -123a 0123} {%x%x%x} x y z] $x $y $z -} {3 4664 -4666 291} -test scan-4.40 {Tcl_ScanObjCmd, base-16 integer scanning} { +} -result {3 4664 -4666 291} +test scan-4.40 {Tcl_ScanObjCmd, base-16 integer scanning} -setup { + set x {} +} -body { # The behavior changed in 8.4a4/8.3.4cvs (6 Feb) to correctly # return '1' for 0x1 scanned via %x, to comply with 8.0 and C scanf. # Bug #495213 - set x {} list [scan {aBcDeF AbCdEf 0x1} {%x%x%x} x y z] $x $y $z -} {3 11259375 11259375 1} -test scan-4.40.1 {Tcl_ScanObjCmd, base-16 integer scanning} { +} -result {3 11259375 11259375 1} +test scan-4.40.1 {Tcl_ScanObjCmd, base-16 integer scanning} -setup { set x {} +} -body { list [scan {0xF 0x00A0B 0X0XF} {%x %x %x} x y z] $x $y $z -} {3 15 2571 0} -test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} { - catch {unset x} +} -result {3 15 2571 0} +test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} -setup { + unset -nocomplain x +} -body { list [scan {xF} {%x} x] [info exists x] -} {0 0} -test scan-4.40.3 {Tcl_ScanObjCmd, base-2 integer scanning} { +} -result {0 0} +test scan-4.40.3 {Tcl_ScanObjCmd, base-2 integer scanning} -setup { set x {} +} -body { list [scan {1001 0b101 100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} {%b %b %llb} x y z] $x $y $z -} {3 9 5 340282366920938463463374607431768211456} -test scan-4.41 {Tcl_ScanObjCmd, base-unknown integer scanning} { +} -result {3 9 5 340282366920938463463374607431768211456} +test scan-4.41 {Tcl_ScanObjCmd, base-unknown integer scanning} -setup { set x {} +} -body { list [scan {10 010 0x10 0b10} {%i%i%i%i} x y z t] $x $y $z $t -} {4 10 8 16 0} -test scan-4.42 {Tcl_ScanObjCmd, base-unknown integer scanning} { +} -result {4 10 8 16 0} +test scan-4.42 {Tcl_ScanObjCmd, base-unknown integer scanning} -setup { set x {} +} -body { list [scan {10 010 0X10} {%i%i%i} x y z] $x $y $z -} {3 10 8 16} -test scan-4.43 {Tcl_ScanObjCmd, integer scanning, odd cases} { +} -result {3 10 8 16} +test scan-4.43 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup { set x {} +} -body { list [scan {+ } {%i} x] $x -} {0 {}} -test scan-4.44 {Tcl_ScanObjCmd, integer scanning, odd cases} { +} -result {0 {}} +test scan-4.44 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup { set x {} +} -body { list [scan {+} {%i} x] $x -} {-1 {}} -test scan-4.45 {Tcl_ScanObjCmd, integer scanning, odd cases} { +} -result {-1 {}} +test scan-4.45 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup { set x {} +} -body { list [scan {0x} {%i%s} x y] $x $y -} {2 0 x} -test scan-4.46 {Tcl_ScanObjCmd, integer scanning, odd cases} { +} -result {2 0 x} +test scan-4.46 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup { set x {} +} -body { list [scan {0X} {%i%s} x y] $x $y -} {2 0 X} -test scan-4.47 {Tcl_ScanObjCmd, integer scanning, suppressed} { +} -result {2 0 X} +test scan-4.47 {Tcl_ScanObjCmd, integer scanning, suppressed} -setup { set x {} +} -body { list [scan {123def} {%*i%s} x] $x -} {1 def} +} -result {1 def} test scan-4.48 {Tcl_ScanObjCmd, float scanning} { list [scan {1 2 3} {%e %f %g} x y z] $x $y $z } {3 1.0 2.0 3.0} test scan-4.49 {Tcl_ScanObjCmd, float scanning} { list [scan {.1 0.2 3.} {%e %f %g} x y z] $x $y $z } {3 0.1 0.2 3.0} +test scan-4.49-uc-1 {Tcl_ScanObjCmd, float scanning} { + list [scan {0.5*0.75} {%E%c%G} x y z] $x $y $z +} {3 0.5 42 0.75} +test scan-4.49-uc-2 {Tcl_ScanObjCmd, float scanning} { + list [scan {5e-1*75E-2} {%E%c%G} x y z] $x $y $z +} {3 0.5 42 0.75} test scan-4.50 {Tcl_ScanObjCmd, float scanning} { list [scan {1234567890a} %f x] $x } {1 1234567890.0} @@ -299,133 +396,137 @@ test scan-4.53 {Tcl_ScanObjCmd, float scanning} { test scan-4.54 {Tcl_ScanObjCmd, float scanning} { list [scan {1.0e-1} %f x] $x } {1 0.1} -test scan-4.55 {Tcl_ScanObjCmd, odd cases} { +test scan-4.55 {Tcl_ScanObjCmd, odd cases} -setup { set x {} +} -body { list [scan {+} %f x] $x -} {-1 {}} -test scan-4.56 {Tcl_ScanObjCmd, odd cases} { +} -result {-1 {}} +test scan-4.56 {Tcl_ScanObjCmd, odd cases} -setup { set x {} +} -body { list [scan {1.0e} %f%s x y] $x $y -} {2 1.0 e} -test scan-4.57 {Tcl_ScanObjCmd, odd cases} { +} -result {2 1.0 e} +test scan-4.57 {Tcl_ScanObjCmd, odd cases} -setup { set x {} +} -body { list [scan {1.0e+} %f%s x y] $x $y -} {2 1.0 e+} -test scan-4.58 {Tcl_ScanObjCmd, odd cases} { +} -result {2 1.0 e+} +test scan-4.58 {Tcl_ScanObjCmd, odd cases} -setup { set x {} set y {} +} -body { list [scan {e1} %f%s x y] $x $y -} {0 {} {}} +} -result {0 {} {}} test scan-4.59 {Tcl_ScanObjCmd, float scanning} { list [scan {1.0e-1x} %*f%n x] $x } {1 6} -test scan-4.60 {Tcl_ScanObjCmd, set errors} { +test scan-4.60 {Tcl_ScanObjCmd, set errors} -setup { set x {} set y {} - catch {unset z}; array set z {} - set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \ - $msg $x $y] - unset z - set result -} {1 {can't set "z": variable is array} abc ghi} -test scan-4.61 {Tcl_ScanObjCmd, set errors} { + unset -nocomplain z +} -body { + array set z {} + list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] $msg $x $y +} -cleanup { + unset -nocomplain z +} -result {1 {can't set "z": variable is array} abc ghi} +test scan-4.61 {Tcl_ScanObjCmd, set errors} -setup { set x {} - catch {unset y}; array set y {} - catch {unset z}; array set z {} - set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \ - $msg $x] - unset y - unset z - set result -} {1 {can't set "z": variable is array} abc} - -# procedure that returns the range of integers - -proc int_range {} { - for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} { - set MIN_INT [expr { $MIN_INT << 1 }] - } - set MIN_INT [expr {int($MIN_INT)}] - set MAX_INT [expr { ~ $MIN_INT }] - return [list $MIN_INT $MAX_INT] -} + unset -nocomplain y + unset -nocomplain z +} -body { + array set y {} + array set z {} + list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] $msg $x +} -cleanup { + unset -nocomplain y + unset -nocomplain z +} -result {1 {can't set "z": variable is array} abc} test scan-4.62 {scanning of large and negative octal integers} { - foreach { MIN_INT MAX_INT } [int_range] {} + lassign [int_range] MIN_INT MAX_INT set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT] list [scan $scanstring {%o %o %o} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] } {3 1 1 1} test scan-4.63 {scanning of large and negative hex integers} { - foreach { MIN_INT MAX_INT } [int_range] {} + lassign [int_range] MIN_INT MAX_INT set scanstring [format {%x %x %x} -1 $MIN_INT $MAX_INT] list [scan $scanstring {%x %x %x} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] } {3 1 1 1} +test scan-4.64 {scanning of hex with %X} { + scan "123 abc f78" %X%X%X +} {291 2748 3960} -# clean up from last two tests - -catch { - rename int_range {} -} - -test scan-5.1 {integer scanning} { +test scan-5.1 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "-20 1476 \n33 0" "%d %d %d %d" a b c d] $a $b $c $d -} {4 -20 1476 33 0} -test scan-5.2 {integer scanning} { +} -result {4 -20 1476 33 0} +test scan-5.2 {integer scanning} -setup { set a {}; set b {}; set c {} +} -body { list [scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c] $a $b $c -} {3 -4 16 7890} -test scan-5.3 {integer scanning} { +} -result {3 -4 16 7890} +test scan-5.3 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "-45 16 +10 987" "%ld %d %ld %d" a b c d] $a $b $c $d -} {4 -45 16 10 987} -test scan-5.4 {integer scanning} { +} -result {4 -45 16 10 987} +test scan-5.4 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "14 1ab 62 10" "%d %x %lo %x" a b c d] $a $b $c $d -} {4 14 427 50 16} -test scan-5.5 {integer scanning} { +} -result {4 14 427 50 16} +test scan-5.5 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "12345670 1234567890ab cdefg" "%o %o %x %lx" a b c d] \ $a $b $c $d -} {4 2739128 342391 561323 52719} -test scan-5.6 {integer scanning} { +} -result {4 2739128 342391 561323 52719} +test scan-5.6 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "ab123-24642" "%2x %3x %3o %2o" a b c d] $a $b $c $d -} {4 171 291 -20 52} -test scan-5.7 {integer scanning} { +} -result {4 171 291 -20 52} +test scan-5.7 {integer scanning} -setup { set a {}; set b {} +} -body { list [scan "1234567 234 567 " "%*3x %x %*o %4o" a b] $a $b -} {2 17767 375} -test scan-5.8 {integer scanning} { +} -result {2 17767 375} +test scan-5.8 {integer scanning} -setup { set a {}; set b {} +} -body { list [scan "a 1234" "%d %d" a b] $a $b -} {0 {} {}} -test scan-5.9 {integer scanning} { - set a {}; set b {}; set c {}; set d {}; +} -result {0 {} {}} +test scan-5.9 {integer scanning} -setup { + set a {}; set b {}; set c {}; set d {} +} -body { list [scan "12345678" "%2d %2d %2ld %2d" a b c d] $a $b $c $d -} {4 12 34 56 78} -test scan-5.10 {integer scanning} { +} -result {4 12 34 56 78} +test scan-5.10 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d -} {2 1 2 {} {}} +} -result {2 1 2 {} {}} # -# The behavior for scaning intergers larger than MAX_INT is -# not defined by the ANSI spec. Some implementations wrap the -# input (-16) some return MAX_INT. +# The behavior for scaning intergers larger than MAX_INT is not defined by the +# ANSI spec. Some implementations wrap the input (-16) some return MAX_INT. # -test scan-5.11 {integer scanning} {nonPortable} { - set a {}; set b {}; +test scan-5.11 {integer scanning} -constraints {nonPortable} -setup { + set a {}; set b {} +} -body { list [scan "4294967280 4294967280" "%u %d" a b] $a \ [expr {$b == -16 || $b == 0x7fffffff}] -} {2 4294967280 1} -test scan-5.12 {integer scanning} {wideIs64bit} { +} -result {2 4294967280 1} +test scan-5.12 {integer scanning} -constraints {wideIs64bit} -setup { set a {}; set b {}; set c {} +} -body { list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \ %ld,%lx,%lo a b c] $a $b $c -} {3 7810179016327718216 7810179016327718216 7810179016327718216} +} -result {3 7810179016327718216 7810179016327718216 7810179016327718216} test scan-5.13 {integer scanning and overflow} { # This test used to fail on some 64-bit systems. [Bug 1011860] scan {300000000 3000000000 30000000000} {%ld %ld %ld} @@ -435,153 +536,184 @@ test scan-5.14 {integer scanning} { scan 0xff %u } 0 -test scan-6.1 {floating-point scanning} { +test scan-6.1 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d -} {3 2.1 -300000000.0 0.99962 {}} -test scan-6.2 {floating-point scanning} { +} -result {3 2.1 -300000000.0 0.99962 {}} +test scan-6.2 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d -} {4 -1.0 234.0 5.0 8.2} -test scan-6.3 {floating-point scanning} { +} -result {4 -1.0 234.0 5.0 8.2} +test scan-6.3 {floating-point scanning} -setup { set a {}; set b {}; set c {} +} -body { list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c -} {3 10000.0 30000.0} +} -result {3 10000.0 30000.0} # -# Some libc implementations consider 3.e- bad input. The ANSI -# spec states that digits must follow the - sign. +# Some libc implementations consider 3.e- bad input. The ANSI spec states +# that digits must follow the - sign. # -test scan-6.4 {floating-point scanning} { +test scan-6.4 {floating-point scanning} -setup { set a {}; set b {}; set c {} +} -body { list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c -} {3 1.0 200.0 3.0} -test scan-6.5 {floating-point scanning} { +} -result {3 1.0 200.0 3.0} +test scan-6.5 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d -} {4 4.6 99999.7 87.643 118.0} -test scan-6.6 {floating-point scanning} { +} -result {4 4.6 99999.7 87.643 118.0} +test scan-6.6 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d -} {4 1.2345 0.697 124.0 5e-5} -test scan-6.7 {floating-point scanning} { +} -result {4 1.2345 0.697 124.0 5e-5} +test scan-6.7 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d -} {1 4.6 {} {} {}} -test scan-6.8 {floating-point scanning} { +} -result {1 4.6 {} {} {}} +test scan-6.8 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d -} {2 4.6 5.2 {} {}} +} -result {2 4.6 5.2 {} {}} -test scan-7.1 {string and character scanning} { +test scan-7.1 {string and character scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d -} {4 abc def ghijk dum} -test scan-7.2 {string and character scanning} { +} -result {4 abc def ghijk dum} +test scan-7.2 {string and character scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "a bcdef" "%c%c%1s %s" a b c d] $a $b $c $d -} {4 97 32 b cdef} -test scan-7.3 {string and character scanning} { +} -result {4 97 32 b cdef} +test scan-7.3 {string and character scanning} -setup { set a {}; set b {}; set c {} +} -body { list [scan "123456 test " "%*c%*s %s %s %s" a b c] $a $b $c -} {1 test {} {}} -test scan-7.4 {string and character scanning} { - set a {}; set b {}; set c {}; set d +} -result {1 test {} {}} +test scan-7.4 {string and character scanning} -setup { + set a {}; set b {}; set c {}; set d {} +} -body { list [scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d] $a $b $c $d -} {4 abab cd {01234 } {f 12345}} -test scan-7.5 {string and character scanning} { +} -result {4 abab cd {01234 } {f 12345}} +test scan-7.5 {string and character scanning} -setup { set a {}; set b {}; set c {} +} -body { list [scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c] $a $b $c -} {3 aabc bcdefg 43} -test scan-7.6 {string and character scanning, unicode} { +} -result {3 aabc bcdefg 43} +test scan-7.6 {string and character scanning, unicode} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d -} "4 abc d\u00c7f ghijk dum" -test scan-7.7 {string and character scanning, unicode} { +} -result "4 abc d\u00c7f ghijk dum" +test scan-7.7 {string and character scanning, unicode} -setup { set a {}; set b {} +} -body { list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b -} "2 199 99" -test scan-7.8 {string and character scanning, unicode} { +} -result "2 199 99" +test scan-7.8 {string and character scanning, unicode} -setup { set a {}; set b {} +} -body { list [scan "ab\ufeffdef" "%\[ab\ufeff\]" a] $a -} "1 ab\ufeff" +} -result "1 ab\ufeff" -test scan-8.1 {error conditions} { - catch {scan a} -} 1 -test scan-8.2 {error conditions} { - catch {scan a} msg - set msg -} {wrong # args: should be "scan string format ?varName ...?"} -test scan-8.3 {error conditions} { - list [catch {scan a %D x} msg] $msg -} {1 {bad scan conversion character "D"}} -test scan-8.4 {error conditions} { - list [catch {scan a %O x} msg] $msg -} {1 {bad scan conversion character "O"}} -test scan-8.5 {error conditions} { - list [catch {scan a %X x} msg] $msg -} {1 {bad scan conversion character "X"}} -test scan-8.6 {error conditions} { - list [catch {scan a %F x} msg] $msg -} {1 {bad scan conversion character "F"}} -test scan-8.7 {error conditions} { - list [catch {scan a %E x} msg] $msg -} {1 {bad scan conversion character "E"}} -test scan-8.8 {error conditions} { - list [catch {scan a "%d %d" a} msg] $msg -} {1 {different numbers of variable names and field specifiers}} -test scan-8.9 {error conditions} { - list [catch {scan a "%d %d" a b c} msg] $msg -} {1 {variable is not assigned by any conversion specifiers}} -test scan-8.10 {error conditions} { +test scan-8.1 {error conditions} -body { + scan a +} -returnCodes error -match glob -result * +test scan-8.2 {error conditions} -returnCodes error -body { + scan a +} -result {wrong # args: should be "scan string format ?varName ...?"} +test scan-8.3 {error conditions} -returnCodes error -body { + scan a %D x +} -result {bad scan conversion character "D"} +test scan-8.4 {error conditions} -returnCodes error -body { + scan a %O x +} -result {bad scan conversion character "O"} +test scan-8.5 {error conditions} -returnCodes error -body { + scan a %B x +} -result {bad scan conversion character "B"} +test scan-8.6 {error conditions} -returnCodes error -body { + scan a %F x +} -result {bad scan conversion character "F"} +test scan-8.7 {error conditions} -returnCodes error -body { + scan a %p x +} -result {bad scan conversion character "p"} +test scan-8.8 {error conditions} -returnCodes error -body { + scan a "%d %d" a +} -result {different numbers of variable names and field specifiers} +test scan-8.9 {error conditions} -returnCodes error -body { + scan a "%d %d" a b c +} -result {variable is not assigned by any conversion specifiers} +test scan-8.10 {error conditions} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [expr {[scan " a" " a %d %d %d %d" a b c d] <= 0}] $a $b $c $d -} {1 {} {} {} {}} -test scan-8.11 {error conditions} { +} -result {1 {} {} {} {}} +test scan-8.11 {error conditions} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d -} {2 1 2 {} {}} -test scan-8.12 {error conditions} { - catch {unset a} +} -result {2 1 2 {} {}} +test scan-8.12 {error conditions} -setup { + unset -nocomplain a +} -body { set a(0) 44 - list [catch {scan 44 %d a} msg] $msg -} {1 {can't set "a": variable is array}} -test scan-8.13 {error conditions} { - catch {unset a} + scan 44 %d a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {can't set "a": variable is array} +test scan-8.13 {error conditions} -setup { + unset -nocomplain a +} -body { set a(0) 44 - list [catch {scan 44 %c a} msg] $msg -} {1 {can't set "a": variable is array}} -test scan-8.14 {error conditions} { - catch {unset a} + scan 44 %c a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {can't set "a": variable is array} +test scan-8.14 {error conditions} -setup { + unset -nocomplain a +} -body { set a(0) 44 - list [catch {scan 44 %s a} msg] $msg -} {1 {can't set "a": variable is array}} -test scan-8.15 {error conditions} { - catch {unset a} + scan 44 %s a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {can't set "a": variable is array} +test scan-8.15 {error conditions} -setup { + unset -nocomplain a +} -body { set a(0) 44 - list [catch {scan 44 %f a} msg] $msg -} {1 {can't set "a": variable is array}} -test scan-8.16 {error conditions} { - catch {unset a} + scan 44 %f a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {can't set "a": variable is array} +test scan-8.16 {error conditions} -setup { + unset -nocomplain a +} -body { set a(0) 44 - list [catch {scan 44 %f a} msg] $msg -} {1 {can't set "a": variable is array}} -catch {unset a} -test scan-8.17 {error conditions} { - list [catch {scan 44 %2c a} msg] $msg -} {1 {field width may not be specified in %c conversion}} -test scan-8.18 {error conditions} { - list [catch {scan abc {%[} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-8.19 {error conditions} { - list [catch {scan abc {%[^a} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-8.20 {error conditions} { - list [catch {scan abc {%[^]a} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-8.21 {error conditions} { - list [catch {scan abc {%[]a} x} msg] $msg -} {1 {unmatched [ in format string}} + scan 44 %f a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {can't set "a": variable is array} +test scan-8.17 {error conditions} -returnCodes error -body { + scan 44 %2c a +} -result {field width may not be specified in %c conversion} +test scan-8.18 {error conditions} -returnCodes error -body { + scan abc {%[} x +} -result {unmatched [ in format string} +test scan-8.19 {error conditions} -returnCodes error -body { + scan abc {%[^a} x +} -result {unmatched [ in format string} +test scan-8.20 {error conditions} -returnCodes error -body { + scan abc {%[^]a} x +} -result {unmatched [ in format string} +test scan-8.21 {error conditions} -returnCodes error -body { + scan abc {%[]a} x +} -result {unmatched [ in format string} test scan-9.1 {lots of arguments} { scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 @@ -591,27 +723,32 @@ test scan-9.2 {lots of arguments} { set a20 } 200 -test scan-10.1 {miscellaneous tests} { +test scan-10.1 {miscellaneous tests} -setup { set a {} +} -body { list [scan ab16c ab%dc a] $a -} {1 16} -test scan-10.2 {miscellaneous tests} { +} -result {1 16} +test scan-10.2 {miscellaneous tests} -setup { set a {} +} -body { list [scan ax16c ab%dc a] $a -} {0 {}} -test scan-10.3 {miscellaneous tests} { +} -result {0 {}} +test scan-10.3 {miscellaneous tests} -setup { set a {} +} -body { list [catch {scan ab%c114 ab%%c%d a} msg] $msg $a -} {0 1 114} -test scan-10.4 {miscellaneous tests} { +} -result {0 1 114} +test scan-10.4 {miscellaneous tests} -setup { set a {} +} -body { list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a -} {0 1 14} -test scan-10.5 {miscellaneous tests} { - catch {unset arr} +} -result {0 1 14} +test scan-10.5 {miscellaneous tests} -setup { + unset -nocomplain arr +} -body { set arr(2) {} list [catch {scan ab%c14 ab%%c%d arr(2)} msg] $msg $arr(2) -} {0 1 14} +} -result {0 1 14} test scan-10.6 {miscellaneous tests} { scan 5a {%i%[a]} } {5 a} @@ -671,9 +808,9 @@ test scan-13.1 {Tcl_ScanObjCmd, inline XPG case} { test scan-13.2 {Tcl_ScanObjCmd, inline XPG case} { scan abc {%1$c%2$c%3$c%4$c} } {97 98 99 {}} -test scan-13.3 {Tcl_ScanObjCmd, inline XPG case} { - list [catch {scan abc {%1$c%1$c}} msg] $msg -} {1 {variable is assigned by multiple "%n$" conversion specifiers}} +test scan-13.3 {Tcl_ScanObjCmd, inline XPG case} -returnCodes error -body { + scan abc {%1$c%1$c} +} -result {variable is assigned by multiple "%n$" conversion specifiers} test scan-13.4 {Tcl_ScanObjCmd, inline XPG case} { scan abc {%2$s%1$c} } {{} abc} @@ -692,77 +829,20 @@ test scan-13.8 {Tcl_ScanObjCmd, inline XPG case lots of arguments} { list [llength $msg] [lindex $msg 99] [lindex $msg 4] [lindex $msg 199] } {200 10 20 30} -# Big test for correct ordering of data in [expr] - -proc testIEEE {} { - variable ieeeValues - binary scan [binary format dd -1.0 1.0] c* c - switch -exact -- $c { - {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { - # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ - ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ - ieeeValues(-Normal) - binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ - ieeeValues(-Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ - ieeeValues(-0) - binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+0) - binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ - ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ - ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ - ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ - ieeeValues(NaN) - set ieeeValues(littleEndian) 1 - return 1 - } - {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-Normal) - binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-Subnormal) - binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-0) - binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+0) - binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(NaN) - set ieeeValues(littleEndian) 0 - return 1 - } - default { - return 0 - } - } -} - -testConstraint ieeeFloatingPoint [testIEEE] - # scan infinities - not working -test scan-14.1 {infinity} { +test scan-14.1 {positive infinity} { scan Inf %g d - set d + return $d } Inf -test scan-14.2 {infinity} { +test scan-14.2 {negative infinity} { scan -Inf %g d - set d + return $d } -Inf # TODO - also need to scan NaN's + +catch {rename int_range {}} # cleanup ::tcltest::cleanupTests diff --git a/tests/set-old.test b/tests/set-old.test index 52dc0ff..4c25ec5 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -678,6 +678,11 @@ test set-old-8.57 {array command, array get with trivial pattern} { set a(y) 2 array get a x } {x 1} +test set-old-8.58 {array command, array set with LVT and odd length literal} { + list [catch {apply {{} { + array set a {b c d} + }}} msg] $msg +} {1 {list must have an even number of elements}} test set-old-9.1 {ids for array enumeration} { catch {unset a} diff --git a/tests/set.test b/tests/set.test index 1d88553..18119f5 100644 --- a/tests/set.test +++ b/tests/set.test @@ -524,6 +524,11 @@ test set-5.1 {error on malformed array name} testset2 { list $msg $msg1 } {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}} +# In a mem-debug build, this test will crash unless Bug 3602706 is fixed. +test set-5.2 {Bug 3602706} -body { + testset2 ::tcl_platform not-in-there +} -returnCodes error -result * -match glob + # cleanup catch {unset a} catch {unset b} diff --git a/tests/socket.test b/tests/socket.test index 5542c09..51219e6 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1841,6 +1841,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ after cancel $after close $client close $server + unset x } -result {{} bye} test socket-14.5 {[socket -async] which fails before any connect() can be made} \ -constraints [list socket supported_any] \ @@ -1850,6 +1851,33 @@ test socket-14.5 {[socket -async] which fails before any connect() can be made} } \ -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} +test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \ + -constraints [list socket supported_inet supported_inet6] \ + -setup { + proc accept {s a p} { + puts $s bye + close $s + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + foreach _ {1 2} { + lappend x [lindex [fconfigure $client -sockname] 0] + lappend x [fconfigure $client -error] + update + } + lappend x [gets $client] + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result [list ::1 "connection refused" 127.0.0.1 "" bye] + ::tcltest::cleanupTests flush stdout return diff --git a/tests/source.test b/tests/source.test index d71212d..0235bd1 100644 --- a/tests/source.test +++ b/tests/source.test @@ -187,6 +187,16 @@ test source-3.5 {return with special code etc.} -setup { invoked from within "source $sourcefile"} {a b c}} +test source-4.1 {continuation line parsing} -setup { + set sourcefile [makeFile [string map {CL \\\n} { + format %s "[dict get [info frame 0] type]:CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]" + }] source.file] +} -body { + source $sourcefile +} -cleanup { + removeFile source.file +} -result {source: 3 4 5} + test source-6.1 {source is binary ok} -setup { # Note [makeFile] writes in the system encoding. # [source] defaults to reading in the system encoding. diff --git a/tests/stack.test b/tests/stack.test index 873cb08..13bc524 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -9,10 +9,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* # Note that a failure in this test may result in a crash of the executable. diff --git a/tests/string.test b/tests/string.test index f558d30..740cdc6 100644 --- a/tests/string.test +++ b/tests/string.test @@ -408,13 +408,15 @@ test string-6.35 {string is double, false} { test string-6.36 {string is double, false} { list [string is double -fail var "\n"] $var } {0 0} -test string-6.37 {string is double, false on int overflow} { +test string-6.37 {string is double, false on int overflow} -setup { + set var priorValue +} -body { # Make it the largest int recognizable, with one more digit for overflow # Since bignums arrived in Tcl 8.5, the sense of this test changed. # Now integer values that exceed native limits become bignums, and # bignums can convert to doubles without error. list [string is double -fail var [largest_int]0] $var -} {1 0} +} -result {1 priorValue} # string-6.38 removed, underflow on input is no longer an error. test string-6.39 {string is double, false} { # This test is non-portable because IRIX thinks diff --git a/tests/subst.test b/tests/subst.test index 4be4798..7466895 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -293,6 +293,10 @@ test subst-13.1 {Bug 3081065} -setup { } -cleanup { removeFile subst13.tcl } +test subst-13.2 {Test for segfault} -body { + subst {[} +} -returnCodes error -result * -match glob + # cleanup ::tcltest::cleanupTests diff --git a/tests/tcltest.test b/tests/tcltest.test index 86aca6f..ce8d617 100755 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -80,10 +80,7 @@ proc slave {msgVar args} { # Need to capture output in msg - set code [catch {i eval {source $argv0}} foo] -if $code { -#puts "$code: $foo\n$::errorInfo" -} + set code [catch {i eval {source $argv0}}] i eval {close $tcltest::outputChannel} interp delete [namespace current]::i set f [open $of] @@ -99,8 +96,6 @@ if $code { append msg \n$err } return $code - -# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg] } test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} { set result [slave msg test.tcl] @@ -549,7 +544,7 @@ set notWriteableDir [file join [temporaryDirectory] notwriteable] makeDirectory notreadable makeDirectory notwriteable switch -- $::tcl_platform(platform) { - "unix" { + unix { file attributes $notReadableDir -permissions 00333 file attributes $notWriteableDir -permissions 00555 } @@ -716,8 +711,8 @@ test tcltest-8.60 {::workingDirectory} { # clean up from directory testing -switch $::tcl_platform(platform) { - "unix" { +switch -- $::tcl_platform(platform) { + unix { file attributes $notReadableDir -permissions 777 file attributes $notWriteableDir -permissions 777 } @@ -727,7 +722,7 @@ switch $::tcl_platform(platform) { } } -file delete -force $notReadableDir $notWriteableDir +file delete -force -- $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory @@ -1150,7 +1145,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { } -cleanup { interp delete slave2 interp delete slave1 - if {$oldoptions == "none"} { + if {$oldoptions eq "none"} { unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions diff --git a/tests/thread.test b/tests/thread.test index d79f693..f32ef61 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -84,28 +84,6 @@ if {[testConstraint testthread]} { } testthread errorproc ThreadError - - set mainThread [testthread id] - - proc ThreadNullError {id info} { - # ignore - } - - proc threadReap {} { - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != [testthread id]} { - catch { - testthread send -async $tid {testthread exit} - } - } - } - after 1 - } - testthread errorproc ThreadError - return [llength [testthread names]] - } } # Some tests require manual draining of the event queue diff --git a/tests/tm.test b/tests/tm.test index 149a65d..1b22f8c 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -200,7 +200,7 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup { proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] - foreach {major minor} [split [info tclversion] .] break + lassign [split [package present Tcl] .] major minor set results {} set base [file join $base tcl$major] lappend results [file join $base site-tcl] diff --git a/tests/trace.test b/tests/trace.test index 0f48dcf..d830f3c 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,10 +11,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] @@ -32,15 +30,15 @@ proc getbytes {} { proc traceScalar {name1 name2 op} { global info - set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg] + set info [list $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg] } proc traceScalarAppend {name1 name2 op} { global info - lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg + lappend info $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg } proc traceArray {name1 name2 op} { global info - set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg] + set info [list $name1 $name2 $op [catch {uplevel 1 set [set name1]($name2)} msg] $msg] } proc traceArray2 {name1 name2 op} { global info @@ -62,7 +60,7 @@ proc traceCheck {cmd args} { set info [list [catch $cmd msg] $msg] } proc traceCrtElement {value name1 name2 op} { - uplevel set ${name1}($name2) $value + uplevel 1 set ${name1}($name2) $value } proc traceCommand {oldName newName op} { global info @@ -72,10 +70,10 @@ proc traceCommand {oldName newName op} { test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { # You may need Purify or Electric Fence to reliably # see this one fail. - catch {unset z} + unset -nocomplain z trace add variable z array {set z(foo) 1 ;#} set res "names: [array names z]" - catch {unset ::z} + unset -nocomplain ::z trace variable ::z w {unset ::z; error "memory corruption";#} list [catch {set ::z 1} msg] $msg } {1 {can't set "::z": memory corruption}} @@ -83,40 +81,40 @@ test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { # Read-tracing on variables test trace-1.1 {trace variable reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}} test trace-1.2 {trace variable reads} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {0 123 {x {} read 0 123}} test trace-1.3 {trace variable reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceScalar set x 123 set info } {} test trace-1.4 {trace array element reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}} test trace-1.5 {trace array element reads} { - catch {unset x} + unset -nocomplain x set x(2) zzz set info {} trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} test trace-1.6 {trace array element reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceArray2 proc p {} { @@ -127,7 +125,7 @@ test trace-1.6 {trace array element reads} { list [catch {p} msg] $msg $info } {0 willi {x 2 read}} test trace-1.7 {trace array element reads, create element undefined if nonexistant} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read q proc q {name1 name2 op} { @@ -144,20 +142,20 @@ test trace-1.7 {trace array element reads, create element undefined if nonexista list [catch {p} msg] $msg $info } {0 wolf {x Y read}} test trace-1.8 {trace reads on whole arrays} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such variable} {}} test trace-1.9 {trace reads on whole arrays} { - catch {unset x} + unset -nocomplain x set x(2) zzz set info {} trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} test trace-1.10 {trace variable reads} { - catch {unset x} + unset -nocomplain x set x 444 set info {} trace add variable x read traceScalar @@ -165,28 +163,28 @@ test trace-1.10 {trace variable reads} { set info } {} test trace-1.11 {read traces that modify the array structure} { - catch {unset x} + unset -nocomplain x set x(bar) 0 trace variable x r {set x(foo) 1 ;#} trace variable x r {unset -nocomplain x(bar) ;#} array get x } {} test trace-1.12 {read traces that modify the array structure} { - catch {unset x} + unset -nocomplain x set x(bar) 0 trace variable x r {unset -nocomplain x(bar) ;#} trace variable x r {set x(foo) 1 ;#} array get x } {} test trace-1.13 {read traces that modify the array structure} { - catch {unset x} + unset -nocomplain x set x(bar) 0 trace variable x r {set x(foo) 1 ;#} trace variable x r {unset -nocomplain x;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} test trace-1.14 {read traces that modify the array structure} { - catch {unset x} + unset -nocomplain x set x(bar) 0 trace variable x r {unset -nocomplain x;#} trace variable x r {set x(foo) 1 ;#} @@ -196,28 +194,28 @@ test trace-1.14 {read traces that modify the array structure} { # Basic write-tracing on variables test trace-2.1 {trace variable writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceScalar set x 123 set info } {x {} write 0 123} test trace-2.2 {trace writes to array elements} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(33) write traceArray set x(33) 444 set info } {x 33 write 0 444} test trace-2.3 {trace writes on whole arrays} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceArray set x(abc) qq set info } {x abc write 0 qq} test trace-2.4 {trace variable writes} { - catch {unset x} + unset -nocomplain x set x 1234 set info {} trace add variable x write traceScalar @@ -225,7 +223,7 @@ test trace-2.4 {trace variable writes} { set info } {} test trace-2.5 {trace variable writes} { - catch {unset x} + unset -nocomplain x set x 1234 set info {} trace add variable x write traceScalar @@ -238,7 +236,7 @@ test trace-2.6 {trace variable writes on compiled local} { # arrays [Bug 1770591]. The corresponding function for read traces is # already indirectly tested in trace-1.7 # - catch {unset x} + unset -nocomplain x set info {} proc p {} { trace add variable x write traceArray @@ -267,7 +265,7 @@ test trace-2.7 {trace variable writes on errorInfo} -body { # trace: after appending all arguments to the list. test trace-3.1 {trace variable read-modify-writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceScalarAppend append x 123 @@ -276,7 +274,7 @@ test trace-3.1 {trace variable read-modify-writes} { set info } {x {} read 0 123456} test trace-3.2 {trace variable read-modify-writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x {read write} traceScalarAppend append x 123 @@ -287,14 +285,14 @@ test trace-3.2 {trace variable read-modify-writes} { # Basic unset-tracing on variables test trace-4.1 {trace variable unsets} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x unset traceScalar - catch {unset x} + unset -nocomplain x set info } {x {} unset 1 {can't read "x": no such variable}} test trace-4.2 {variable mustn't exist during unset trace} { - catch {unset x} + unset -nocomplain x set x 1234 set info {} trace add variable x unset traceScalar @@ -302,7 +300,7 @@ test trace-4.2 {variable mustn't exist during unset trace} { set info } {x {} unset 1 {can't read "x": no such variable}} test trace-4.3 {unset traces mustn't be called during reads and writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x unset traceScalar set x 44 @@ -310,15 +308,15 @@ test trace-4.3 {unset traces mustn't be called during reads and writes} { set info } {} test trace-4.4 {trace unsets on array elements} { - catch {unset x} + unset -nocomplain x set x(0) 18 set info {} trace add variable x(1) unset traceArray - catch {unset x(1)} + unset -nocomplain x(1) set info } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.5 {trace unsets on array elements} { - catch {unset x} + unset -nocomplain x set x(1) 18 set info {} trace add variable x(1) unset traceArray @@ -326,7 +324,7 @@ test trace-4.5 {trace unsets on array elements} { set info } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.6 {trace unsets on array elements} { - catch {unset x} + unset -nocomplain x set x(1) 18 set info {} trace add variable x(1) unset traceArray @@ -334,15 +332,15 @@ test trace-4.6 {trace unsets on array elements} { set info } {x 1 unset 1 {can't read "x(1)": no such variable}} test trace-4.7 {trace unsets on whole arrays} { - catch {unset x} + unset -nocomplain x set x(1) 18 set info {} trace add variable x unset traceProc - catch {unset x(0)} + unset -nocomplain x(0) set info } {} test trace-4.8 {trace unsets on whole arrays} { - catch {unset x} + unset -nocomplain x set x(1) 18 set x(2) 144 set x(3) 14 @@ -352,7 +350,7 @@ test trace-4.8 {trace unsets on whole arrays} { set info } {x 1 unset} test trace-4.9 {trace unsets on whole arrays} { - catch {unset x} + unset -nocomplain x set x(1) 18 set x(2) 144 set x(3) 14 @@ -364,7 +362,7 @@ test trace-4.9 {trace unsets on whole arrays} { # Array tracing on variables test trace-5.1 {array traces fire on accesses via [array]} { - catch {unset x} + unset -nocomplain x set x(b) 2 trace add variable x array traceArray2 set ::info {} @@ -372,7 +370,7 @@ test trace-5.1 {array traces fire on accesses via [array]} { set ::info } {x {} array} test trace-5.2 {array traces do not fire on normal accesses} { - catch {unset x} + unset -nocomplain x set x(b) 2 trace add variable x array traceArray2 set ::info {} @@ -381,7 +379,7 @@ test trace-5.2 {array traces do not fire on normal accesses} { set ::info } {} test trace-5.3 {array traces do not outlive variable} { - catch {unset x} + unset -nocomplain x trace add variable x array traceArray2 set ::info {} set x(a) 1 @@ -390,19 +388,19 @@ test trace-5.3 {array traces do not outlive variable} { set ::info } {} test trace-5.4 {array traces properly listed in trace information} { - catch {unset x} + unset -nocomplain x trace add variable x array traceArray2 set result [trace info variable x] set result } [list [list array traceArray2]] test trace-5.5 {array traces properly listed in trace information} { - catch {unset x} + unset -nocomplain x trace variable x a traceArray2 set result [trace vinfo x] set result } [list [list a traceArray2]] test trace-5.6 {array traces don't fire on scalar variables} { - catch {unset x} + unset -nocomplain x set x foo trace add variable x array traceArray2 set ::info {} @@ -410,14 +408,14 @@ test trace-5.6 {array traces don't fire on scalar variables} { set ::info } {} test trace-5.7 {array traces fire for undefined variables} { - catch {unset x} + unset -nocomplain x trace add variable x array traceArray2 set ::info {} array set x {a 1} set ::info } {x {} array} test trace-5.8 {array traces fire for undefined variables} { - catch {unset x} + unset -nocomplain x trace add variable x array {set x(foo) 1 ;#} set res "names: [array names x]" } {names: foo} @@ -425,7 +423,7 @@ test trace-5.8 {array traces fire for undefined variables} { # Trace multiple trace types at once. test trace-6.1 {multiple ops traced at once} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x {read write unset} traceProc catch {set x} @@ -436,7 +434,7 @@ test trace-6.1 {multiple ops traced at once} { set info } {x {} read x {} write x {} read x {} write x {} unset} test trace-6.2 {multiple ops traced on array element} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) {read write unset} traceProc catch {set x(0)} @@ -448,7 +446,7 @@ test trace-6.2 {multiple ops traced on array element} { set info } {x 0 read x 0 write x 0 read x 0 write x 0 unset} test trace-6.3 {multiple ops traced on whole array} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x {read write unset} traceProc catch {set x(0)} @@ -463,7 +461,7 @@ test trace-6.3 {multiple ops traced on whole array} { # Check order of invocation of traces test trace-7.1 {order of invocation of traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read "traceTag 1" trace add variable x read "traceTag 2" @@ -474,7 +472,7 @@ test trace-7.1 {order of invocation of traces} { set info } {3 2 1 3 2 1} test trace-7.2 {order of invocation of traces} { - catch {unset x} + unset -nocomplain x set x(0) 44 set info {} trace add variable x(0) read "traceTag 1" @@ -484,7 +482,7 @@ test trace-7.2 {order of invocation of traces} { set info } {3 2 1} test trace-7.3 {order of invocation of traces} { - catch {unset x} + unset -nocomplain x set x(0) 44 set info {} trace add variable x(0) read "traceTag 1" @@ -500,7 +498,7 @@ test trace-7.3 {order of invocation of traces} { # Check effects of errors in trace procedures test trace-8.1 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x read "traceTag 1" @@ -508,7 +506,7 @@ test trace-8.1 {error returns from traces} { list [catch {set x} msg] $msg $info } {1 {can't read "x": trace returned error} {}} test trace-8.2 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x write "traceTag 1" @@ -516,14 +514,14 @@ test trace-8.2 {error returns from traces} { list [catch {set x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-8.3 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x write traceError list [catch {append x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-8.4 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x unset "traceTag 1" @@ -531,7 +529,7 @@ test trace-8.4 {error returns from traces} { list [catch {unset x} msg] $msg $info } {0 {} 1} test trace-8.5 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x(0) 123 set info {} trace add variable x(0) read "traceTag 1" @@ -541,7 +539,7 @@ test trace-8.5 {error returns from traces} { list [catch {set x(0)} msg] $msg $info } {1 {can't read "x(0)": trace returned error} 3} test trace-8.6 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 trace add variable x unset traceError list [catch {unset x} msg] $msg @@ -550,7 +548,7 @@ test trace-8.7 {error returns from traces} { # This test just makes sure that the memory for the error message # gets deallocated correctly when the trace is invoked again or # when the trace is deleted. - catch {unset x} + unset -nocomplain x set x 123 trace add variable x read traceError catch {set x} @@ -571,7 +569,7 @@ test trace-8.8 {error returns from traces} { trace add variable ::x write [list foo $::x] error "foo" } - catch {unset ::x ::y} + unset -nocomplain ::x ::y set x junk trace add variable ::x write [list foo $x] for {set y 0} {$y<100} {incr y} { @@ -585,31 +583,31 @@ test trace-8.8 {error returns from traces} { # a new copy of the variables. test trace-9.1 {be sure variable is unset before trace is called} { - catch {unset x} + unset -nocomplain x set x 33 set info {} - trace add variable x unset {traceCheck {uplevel set x}} + trace add variable x unset {traceCheck {uplevel 1 set x}} unset x set info } {1 {can't read "x": no such variable}} test trace-9.2 {be sure variable is unset before trace is called} { - catch {unset x} + unset -nocomplain x set x 33 set info {} - trace add variable x unset {traceCheck {uplevel set x 22}} + trace add variable x unset {traceCheck {uplevel 1 set x 22}} unset x concat $info [list [catch {set x} msg] $msg] } {0 22 0 22} test trace-9.3 {be sure traces are cleared before unset trace called} { - catch {unset x} + unset -nocomplain x set x 33 set info {} - trace add variable x unset {traceCheck {uplevel trace info variable x}} + trace add variable x unset {traceCheck {uplevel 1 trace info variable x}} unset x set info } {0 {}} test trace-9.4 {set new trace during unset trace} { - catch {unset x} + unset -nocomplain x set x 33 set info {} trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}} @@ -618,23 +616,23 @@ test trace-9.4 {set new trace during unset trace} { } {0 {} {unset traceProc}} test trace-10.1 {make sure array elements are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x(0) unset {traceCheck {uplevel set x(0)}} + trace add variable x(0) unset {traceCheck {uplevel 1 set x(0)}} unset x(0) set info } {1 {can't read "x(0)": no such element in array}} test trace-10.2 {make sure array elements are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}} + trace add variable x(0) unset {traceCheck {uplevel 1 set x(0) zzz}} unset x(0) concat $info [list [catch {set x(0)} msg] $msg] } {0 zzz 0 zzz} test trace-10.3 {array elements are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}} @@ -642,49 +640,49 @@ test trace-10.3 {array elements are unset before traces are called} { set info } {0 {}} test trace-10.4 {set new array element trace during unset trace} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}} - catch {unset x(0)} + trace add variable x(0) unset {traceCheck {uplevel 1 {trace add variable x(0) read {}}}} + unset -nocomplain x(0) concat $info [trace info variable x(0)] } {0 {} {read {}}} test trace-11.1 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x unset {traceCheck {uplevel set x(0)}} + trace add variable x unset {traceCheck {uplevel 1 set x(0)}} unset x set info } {1 {can't read "x(0)": no such variable}} test trace-11.2 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} - trace add variable x unset {traceCheck {uplevel set x(y) 22}} + trace add variable x unset {traceCheck {uplevel 1 set x(y) 22}} unset x concat $info [list [catch {set x(y)} msg] $msg] } {0 22 0 22} test trace-11.3 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} - trace add variable x unset {traceCheck {uplevel array exists x}} + trace add variable x unset {traceCheck {uplevel 1 array exists x}} unset x set info } {0 0} test trace-11.4 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} - set cmd {traceCheck {uplevel {trace info variable x}}} + set cmd {traceCheck {uplevel 1 {trace info variable x}}} trace add variable x unset $cmd unset x set info } {0 {}} test trace-11.5 {set new array trace during unset trace} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} trace add variable x unset {traceCheck {global x; trace add variable x read {}}} @@ -692,7 +690,7 @@ test trace-11.5 {set new array trace during unset trace} { concat $info [trace info variable x] } {0 {} {read {}}} test trace-11.6 {create scalar during array unset trace} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} trace add variable x unset {traceCheck {global x; set x 44}} @@ -703,52 +701,52 @@ test trace-11.6 {create scalar during array unset trace} { # Check special conditions (e.g. errors) in Tcl_TraceVar2. test trace-12.1 {creating array when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) write traceProc list [catch {set x 22} msg] $msg } {1 {can't set "x": variable is array}} test trace-12.2 {creating array when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) write traceProc list [catch {set x(0)} msg] $msg } {1 {can't read "x(0)": no such element in array}} test trace-12.3 {creating array when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) write traceProc set x(0) 22 set info } {x 0 write} test trace-12.4 {creating variable when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc list [catch {set x} msg] $msg } {1 {can't read "x": no such variable}} test trace-12.5 {creating variable when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc set x 22 set info } {x {} write} test trace-12.6 {creating variable when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc set x(0) 22 set info } {x 0 write} test trace-12.7 {create array element during read trace} { - catch {unset x} + unset -nocomplain x set x(2) zzz trace add variable x read {traceCrtElement xyzzy} list [catch {set x(3)} msg] $msg } {0 xyzzy} test trace-12.8 {errors when setting variable traces} { - catch {unset x} + unset -nocomplain x set x 44 list [catch {trace add variable x(0) write traceProc} msg] $msg } {1 {can't trace "x(0)": variable isn't array}} @@ -762,7 +760,7 @@ test trace-13.1 {delete one trace from another} { trace remove variable x read {traceTag 3} trace remove variable x read {traceTag 4} } - catch {unset x} + unset -nocomplain x set x 44 set info {} trace add variable x read {traceTag 1} @@ -916,13 +914,13 @@ test trace-14.11 {trace command, "trace variable" errors} { test trace-14.12 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc trace remove variable x write traceProc } {} test trace-14.13 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc trace remove variable x write traceProc @@ -930,7 +928,7 @@ test trace-14.13 {trace command ("remove variable" option)} { set info } {} test trace-14.14 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write {traceTag 1} trace add variable x write traceProc @@ -945,7 +943,7 @@ test trace-14.14 {trace command ("remove variable" option)} { set info } {2 x {} write 1 2 1 2} test trace-14.15 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write {traceTag 1} trace remove variable x write non_existent @@ -953,27 +951,27 @@ test trace-14.15 {trace command ("remove variable" option)} { set info } {1} test trace-14.16 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x trace add variable x write {traceTag 1} trace add variable x write traceProc trace add variable x write {traceTag 2} trace info variable x } {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}} test trace-14.17 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x trace info variable x } {} test trace-14.18 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x trace info variable x(0) } {} test trace-14.19 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x set x 44 trace info variable x(0) } {} test trace-14.20 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x set x 44 trace add variable x write {traceTag 1} proc check {} {global x; trace info variable x} @@ -983,7 +981,7 @@ test trace-14.20 {trace command ("info variable" option)} { # Check fancy trace commands (long ones, weird arguments, etc.) test trace-15.1 {long trace command} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write {traceTag {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ @@ -1001,14 +999,14 @@ test trace-15.2 {long trace command result to ignore} { proc longResult {args} {return "quite a bit of text, designed to generate a core leak if this command file is invoked over and over again and memory isn't being recycled correctly"} - catch {unset x} + unset -nocomplain x trace add variable x write longResult set x 44 set x 5 set x abcde } abcde test trace-15.3 {special list-handling in trace commands} { - catch {unset "x y z"} + unset -nocomplain "x y z" set "x y z(a\n\{)" 44 set info {} trace add variable "x y z(a\n\{)" write traceProc @@ -1020,18 +1018,18 @@ test trace-15.3 {special list-handling in trace commands} { proc traceUnset {unsetName args} { global info - upvar $unsetName x + upvar 1 $unsetName x lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg } proc traceReset {unsetName resetName args} { global info - upvar $unsetName x $resetName y + upvar 1 $unsetName x $resetName y lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg } proc traceReset2 {unsetName resetName args} { global info - lappend info [catch {uplevel unset $unsetName} msg] $msg \ - [catch {uplevel set $resetName xyzzy} msg] $msg + lappend info [catch {uplevel 1 unset $unsetName} msg] $msg \ + [catch {uplevel 1 set $resetName xyzzy} msg] $msg } proc traceAppend {string name1 name2 op} { global info @@ -1039,7 +1037,7 @@ proc traceAppend {string name1 name2 op} { } test trace-16.1 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y read {traceUnset y} @@ -1047,49 +1045,49 @@ test trace-16.1 {unsets during read traces} { lappend info [catch {set y} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-16.2 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceUnset y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} test trace-16.3 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceUnset y} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} test trace-16.4 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y read {traceReset y y} lappend info [catch {set y} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.5 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset y(0) y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.6 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} test trace-16.7 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset2 y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} test trace-16.8 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y write {traceUnset y} @@ -1097,91 +1095,91 @@ test trace-16.8 {unsets during write traces} { lappend info [catch {set y xxx} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.9 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceUnset y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.10 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceUnset y} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.11 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y write {traceReset y y} lappend info [catch {set y xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.12 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset y(0) y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.13 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} test trace-16.14 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset2 y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-16.15 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y unset {traceUnset y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} test trace-16.16 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceUnset y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} test trace-16.17 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceUnset y} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} test trace-16.18 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y unset {traceReset2 y y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} test trace-16.19 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceReset2 y(0) y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} test trace-16.20 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceReset2 y y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-16.21 {unsets cancelling traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y read {traceAppend first} @@ -1191,7 +1189,7 @@ test trace-16.21 {unsets cancelling traces} { lappend info [catch {set y} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-16.22 {unsets cancelling traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceAppend first} @@ -1204,19 +1202,19 @@ test trace-16.22 {unsets cancelling traces} { # Check various non-interference between traces and other things. test trace-17.1 {trace doesn't prevent unset errors} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x unset {traceProc} list [catch {unset x} msg] $msg $info } {1 {can't unset "x": no such variable} {x {} unset}} test trace-17.2 {traced variables must survive procedure exits} { - catch {unset x} + unset -nocomplain x proc p1 {} {global x; trace add variable x write traceProc} p1 trace info variable x } {{write traceProc}} test trace-17.3 {traced variables must survive procedure exits} { - catch {unset x} + unset -nocomplain x set info {} proc p1 {} {global x; trace add variable x write traceProc} p1 @@ -1229,7 +1227,7 @@ test trace-17.3 {traced variables must survive procedure exits} { test trace-18.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} - proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}} + proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}} set info {} p1 foo bar set info @@ -1269,8 +1267,7 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} { # Delete arrays when done, so they can be re-used as scalars # elsewhere. -catch {unset x} -catch {unset y} +unset -nocomplain x y test trace-19.0.1 {trace add command (command existence)} { # Just in case! @@ -1312,6 +1309,7 @@ test trace-19.3 {command rename traces don't fire on command deletion} { test trace-19.4 {trace add command rename doesn't trace recreated commands} { proc foo {} {} catch {rename bar {}} + set info {} trace add command foo rename traceCommand proc foo {} {} rename foo bar @@ -1324,25 +1322,49 @@ test trace-19.5 {trace add command deleted removes traces} { trace info command foo } {} -namespace eval tc {} -proc tc::tcfoo {} {} -test trace-19.6 {trace add command rename in namespace} { +test trace-19.6 {trace add command rename in namespace} -setup { + namespace eval tc {} + proc tc::tcfoo {} {} +} -body { trace add command tc::tcfoo rename traceCommand rename tc::tcfoo tc::tcbar set info -} {::tc::tcfoo ::tc::tcbar rename} -test trace-19.7 {trace add command rename in namespace back again} { +} -cleanup { + namespace delete tc +} -result {::tc::tcfoo ::tc::tcbar rename} +test trace-19.7 {trace add command rename in namespace back again} -setup { + namespace eval tc {} + proc tc::tcfoo {} {} +} -body { + trace add command tc::tcfoo rename traceCommand + rename tc::tcfoo tc::tcbar rename tc::tcbar tc::tcfoo set info -} {::tc::tcbar ::tc::tcfoo rename} -test trace-19.8 {trace add command rename in namespace to out of namespace} { +} -cleanup { + namespace delete tc +} -result {::tc::tcbar ::tc::tcfoo rename} +test trace-19.8 {trace add command rename in namespace to out of namespace} -setup { + namespace eval tc {} + proc tc::tcfoo {} {} +} -body { + trace add command tc::tcfoo rename traceCommand rename tc::tcfoo tcbar set info -} {::tc::tcfoo ::tcbar rename} -test trace-19.9 {trace add command rename back into namespace} { +} -cleanup { + catch {rename tcbar {}} + namespace delete tc +} -result {::tc::tcfoo ::tcbar rename} +test trace-19.9 {trace add command rename back into namespace} -setup { + namespace eval tc {} + proc tc::tcfoo {} {} +} -body { + trace add command tc::tcfoo rename traceCommand + rename tc::tcfoo tcbar rename tcbar tc::tcfoo set info -} {::tcbar ::tc::tcfoo rename} +} -cleanup { + namespace delete tc +} -result {::tcbar ::tc::tcfoo rename} test trace-19.10 {trace add command failed rename doesn't trigger trace} { set info {} proc foo {} {} @@ -1353,11 +1375,18 @@ test trace-19.10 {trace add command failed rename doesn't trigger trace} { } {} catch {rename foo {}} catch {rename bar {}} -test trace-19.11 {trace add command qualifies when renamed in namespace} { + +test trace-19.11 {trace add command qualifies when renamed in namespace} -setup { + namespace eval tc {} + proc tc::tcfoo {} {} +} -body { set info {} + trace add command tc::tcfoo {rename delete} traceCommand namespace eval tc {rename tcfoo tcbar} set info -} {::tc::tcfoo ::tc::tcbar rename} +} -cleanup { + namespace delete tc +} -result {::tc::tcfoo ::tc::tcbar rename} # Make sure it exists again proc foo {} {} @@ -1542,8 +1571,7 @@ proc foo {b} { set a $b } # Delete arrays when done, so they can be re-used as scalars # elsewhere. -catch {unset x} -catch {unset y} +unset -nocomplain x y # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). @@ -1674,6 +1702,16 @@ test trace-21.11 {trace execution and alias} -setup { rename ::x {} } -result {:: ::} +proc set2 args { + set {*}$args +} + +test trace-21.12 {bug 2438181} -setup { + trace add execution set2 leave {puts one two three #;} +} -body { + set2 a hello +} -returnCodes 1 -result {wrong # args: should be "puts ?-nonewline? ?channelId? string"} + proc factorial {n} { if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] } return 1 @@ -2050,7 +2088,7 @@ test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} trace remove execution foo {enter enterstep leavestep leave} \ [list traceExecute foo] rename foo {} - catch {unset a} + unset -nocomplain a join $info "\n" } {foo foo enter foo {set a 1} enterstep @@ -2623,6 +2661,13 @@ test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup { rename dotrace {} rename foo {} } -result {3 | 0 1 1} + +test trace-40.1 {execution trace errors become command errors} { + proc foo args {} + trace add execution foo enter {rename foo {}; error bar;#} + catch foo m + return -level 0 $m[unset m] +} bar # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). @@ -2634,9 +2679,8 @@ catch {rename traceproc {}} catch {rename runbase {}} # Unset the variable when done -catch {unset info} -catch {unset base} +unset -nocomplain info base # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 2453e01..e4613ed 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -365,20 +365,21 @@ test unixFCmd-17.4 {SetPermissionsAttribute} -setup { close [open foo.test w] set ::i 4 -proc permcheck {testnum permstr expected} { +proc permcheck {testnum permList expected} { test $testnum {SetPermissionsAttribute} {unix notRoot} { + set result {} + foreach permstr $permList { file attributes foo.test -permissions $permstr - file attributes foo.test -permissions + lappend result [file attributes foo.test -permissions] + } + set result } $expected } permcheck unixFCmd-17.5 rwxrwxrwx 00777 permcheck unixFCmd-17.6 r--r---w- 00442 -permcheck unixFCmd-17.7 0 00000 -permcheck unixFCmd-17.8 u+rwx,g+r 00740 -permcheck unixFCmd-17.9 u-w 00540 -permcheck unixFCmd-17.10 o+rwx 00547 +permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 00740 00540 00547} permcheck unixFCmd-17.11 --x--x--x 00111 -permcheck unixFCmd-17.12 a+rwx 00777 +permcheck unixFCmd-17.12 {0 a+rwx} {00000 00777} file delete -force -- foo.test test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup { diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test new file mode 100644 index 0000000..120f362 --- /dev/null +++ b/tests/unixForkEvent.test @@ -0,0 +1,45 @@ +# This file contains a collection of tests for the procedures in the file +# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-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. + +package require tcltest 2 +namespace import -force ::tcltest::* + +testConstraint testfork [llength [info commands testfork]] + +# Test if the notifier thread is well initialized in a forked interpreter +# by Tcl_InitNotifier +test unixforkevent-1.1 {fork and test writeable event} \ + -constraints {testfork nonPortable} \ + -body { + set myFolder [makeDirectory unixtestfork] + set pid [testfork] + if {$pid == 0} { + # we are the forked process + set result initialized + set h [open [file join $myFolder test.txt] w] + fileevent $h writable\ + "set result writable;\ + after cancel [after 1000 {set result timeout}]" + vwait result + close $h + makeFile $result result.txt $myFolder + exit + } + # we are the original process + while {![file readable [file join $myFolder result.txt]]} {} + viewFile result.txt $myFolder + } \ + -result {writable} \ + -cleanup { + catch { removeFolder $myFolder } + } + +::tcltest::cleanupTests +return diff --git a/tests/unixInit.test b/tests/unixInit.test index 9ba9c11..05338ed 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -11,7 +11,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.2 -namespace import -force ::tcltest::* +namespace import ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C @@ -44,11 +44,11 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} set pipe1 [open "|[list [interpreter]]" r+] puts $pipe1 { proc accept {channel host port} { - puts $channel {puts [fconfigure stdin -peername]; exit} + puts $channel {puts [chan configure stdin -peername]; exit} close $channel exit } - puts [fconfigure [socket -server accept -myaddr 127.0.0.1 0] -sockname] + puts [chan configure [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 @@ -64,8 +64,8 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} set pipe2 [open "|[list [interpreter] <@$sock]" r] set result [gets $pipe2] # Clear any pending data; stops certain kinds of (non-important) errors - fconfigure $pipe1 -blocking 0; gets $pipe1 - fconfigure $pipe2 -blocking 0; gets $pipe2 + chan configure $pipe1 -blocking 0; gets $pipe1 + chan configure $pipe2 -blocking 0; gets $pipe2 # Close the pipes and the socket. close $pipe2 close $pipe1 @@ -329,7 +329,7 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { } -body { set env(LANG) C set f [open "|[list [interpreter]]" w+] - fconfigure $f -buffering none + chan configure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f @@ -344,7 +344,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup { set env(LANG) japanese set env(LC_ALL) japanese set f [open "|[list [interpreter]]" w+] - fconfigure $f -buffering none + chan configure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f @@ -390,7 +390,7 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { } -returnCodes 0 # cleanup -catch {unset env(LANG)} +unset -nocomplain env(LANG) catch {set env(LANG) $oldlang} unset -nocomplain path ::tcltest::cleanupTests diff --git a/tests/unknown.test b/tests/unknown.test index 40be6602..e80d3a6 100644 --- a/tests/unknown.test +++ b/tests/unknown.test @@ -11,12 +11,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2 +namespace import ::tcltest::* -catch {unset x} +unset -nocomplain x catch {rename unknown unknown.old} test unknown-1.1 {non-existent "unknown" command} { @@ -59,7 +57,7 @@ test unknown-4.1 {errors in "unknown" procedure} { # cleanup catch {rename unknown {}} catch {rename unknown.old unknown} -::tcltest::cleanupTests +cleanupTests return # Local Variables: diff --git a/tests/upvar.test b/tests/upvar.test index e2c9ffd..e93f58a 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -414,6 +414,17 @@ test upvar-9.7 {Tcl_UpVar procedure} testupvar { } {1234} catch {unset a} +test upvar-10.1 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + upvar 1 {*}{ + } [return [incr n -[linenumber]]] x + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + # # Tests for 'namespace upvar'. As the implementation is essentially the same as # for 'upvar', we only test that the variables are linked correctly, i.e., we @@ -536,6 +547,38 @@ test upvar-NS-2.2 {TIP 323} -setup { } -cleanup { namespace delete test_ns_1 } -result {} + +test upvar-NS-3.1 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + namespace upvar {*}{ + } [return [incr n -[linenumber]]] x y + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 +test upvar-NS-3.2 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + namespace upvar :: {*}{ + } [return [incr n -[linenumber]]] x + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 +test upvar-NS-3.3 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + variable x {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + # cleanup ::tcltest::cleanupTests diff --git a/tests/utf.test b/tests/utf.test index c41cfe3..ebab967 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -337,8 +337,8 @@ test utf-21.11 {TclUniCharIsControl} { string is control \u00ad } {1} test utf-21.12 {unicode control char in regc_locale.c} { - # [Bug 3464428] - regexp {^[[:cntrl:]]$} \u00ad + # [Bug 3464428], [Bug a876646efe] + regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad } {1} test utf-22.1 {TclUniCharIsWordChar} { diff --git a/tests/var.test b/tests/var.test index ed7e930..208b361 100644 --- a/tests/var.test +++ b/tests/var.test @@ -748,6 +748,9 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test A useSomeUnlikelyNameHere namespace eval test unset useSomeUnlikelyNameHere } {} +test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} { + apply {{} {unset foo [return ok]}} +} ok test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" @@ -793,6 +796,88 @@ test var-19.1 {crash when freeing locals hashtable: Bug 3037525} { foo ; # This crashes without the fix for the bug rename foo {} } {} + +test var-20.1 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + array set x {a 1} + }} + array size x +} -result 1 +test var-20.2 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + array set x {} + }} + array size x +} -result 0 +test var-20.3 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + array set ::x {a 1} + }} + array size x +} -result 1 +test var-20.4 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + array set ::x {} + }} + array size x +} -result 0 +test var-20.5 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + eval {array set x {a 1}} + }} + array size x +} -result 1 +test var-20.6 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + eval {array set x {}} + }} + array size x +} -result 0 +test var-20.7 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + eval {array set ::x {a 1}} + }} + array size x +} -result 1 +test var-20.8 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + eval {array set ::x {}} + }} + array size x +} -result 0 + +test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + set foo bar + unset foo {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + catch {namespace delete ns} catch {unset arr} diff --git a/tests/zlib.test b/tests/zlib.test index 891dba0..4e51ebb 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -16,6 +16,13 @@ if {"::tcltest" ni [namespace children]} { } testConstraint zlib [llength [info commands zlib]] +testConstraint recentZlib 0 +catch { + # Work around a bug in some versions of zlib; known to manifest on at + # least Mac OS X Mountain Lion... + testConstraint recentZlib \ + [package vsatisfies [zlib::pkgconfig get zlibVersion] 1.2.6] +} test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body { zlib @@ -233,7 +240,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" -test zlib-8.8 {transformtion and fconfigure} -setup { +test zlib-8.8 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict @@ -250,7 +257,7 @@ test zlib-8.8 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} -test zlib-8.9 {transformtion and fconfigure} -setup { +test zlib-8.9 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream decompress] } -constraints zlib -body { @@ -267,16 +274,19 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {3064818174 358 358} -test zlib-8.10 {transformtion and fconfigure} -setup { +test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide -} -constraints zlib -body { +} -constraints {zlib recentZlib} -body { zlib push deflate $outSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] - catch {zlib inflate $compressed} err opt + catch { + zlib inflate $compressed + throw UNREACHABLE "should be unreachable" + } err opt list [string length [zlib deflate $spdyHeaders]] \ [string length $compressed] \ $err [dict get $opt -errorcode] @@ -284,7 +294,7 @@ test zlib-8.10 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {254 212 {data error} {TCL ZLIB DATA}} -test zlib-8.11 {transformtion and fconfigure} -setup { +test zlib-8.11 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream inflate] } -constraints zlib -body { @@ -300,7 +310,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.12 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -317,7 +327,7 @@ test zlib-8.12 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.13 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -334,7 +344,7 @@ test zlib-8.13 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.14 {transformtion and fconfigure} -setup { +test zlib-8.14 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { @@ -350,7 +360,7 @@ test zlib-8.14 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.15 {transformtion and fconfigure} -setup { +test zlib-8.15 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { @@ -366,6 +376,25 @@ test zlib-8.15 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} +test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup { + # Actual data isn't very important; needs to be substantially larger than + # the internal buffer (32kB) and incompressible. + set largeData {} + for {set i 0;expr srand(1)} {$i < 100000} {incr i} { + append largeData [lindex "a b c d e f g h i j k l m n o p" \ + [expr {int(16*rand())}]] + } + set file [makeFile {} test.gz] +} -constraints zlib -body { + set f [open $file wb] + fconfigure $f -buffering none + zlib push gzip $f + puts -nonewline $f $largeData + close $f + file size $file +} -cleanup { + removeFile $file +} -result 57647 test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] |