diff options
Diffstat (limited to 'tests')
92 files changed, 7342 insertions, 1419 deletions
diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test new file mode 100644 index 0000000..3ba5167 --- /dev/null +++ b/tests/aaa_exit.test @@ -0,0 +1,54 @@ +# Commands covered: exit, emphasis on finalization hangs +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-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. + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +test exit-1.1 {normal, quick exit} { + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r] + set aft [after 1000 {set done "Quick exit hangs !!!"}] + fileevent $f readable {after cancel $aft;set done OK} + vwait done + if {$done != "OK"} { + fconfigure $f -blocking 0 + close $f + } else { + if {[catch {close $f} err]} { + set done "Quick exit misbehaves: $err" + } + } + set done +} OK + +test exit-1.2 {full-finalized exit} { + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\"" r] + set aft [after 1000 {set done "Full-finalized exit hangs !!!"}] + fileevent $f readable {after cancel $aft;set done OK} + vwait done + if {$done != "OK"} { + fconfigure $f -blocking 0 + close $f + } else { + if {[catch {close $f} err]} { + set done "Full-finalized exit misbehaves: $err" + } + } + set done +} OK + + +# cleanup +::tcltest::cleanupTests +return diff --git a/tests/all.tcl b/tests/all.tcl index 05d3024..0a6f57f 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -15,5 +15,8 @@ package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] +if {[singleProcess]} { + interp debug {} -frame 1 +} runAllTests proc exit args {} diff --git a/tests/append.test b/tests/append.test index 69c6381..8fa4e61 100644 --- a/tests/append.test +++ b/tests/append.test @@ -292,6 +292,23 @@ test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env } -cleanup { unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} + +test append-10.1 {Bug 214cc0eb22: lappend with no values} { + set lst "# 1 2 3" + [subst lappend] lst +} "# 1 2 3" +test append-10.2 {Bug 214cc0eb22: lappend with no values} -body { + set lst "1 \{ 2" + [subst lappend] lst +} -returnCodes error -result {unmatched open brace in list} +test append-10.3 {Bug 214cc0eb22: expanded lappend with no values} { + set lst "# 1 2 3" + [subst lappend] lst {*}[list] +} "# 1 2 3" +test append-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body { + set lst "1 \{ 2" + [subst lappend] lst {*}[list] +} -returnCodes error -result {unmatched open brace in list} unset -nocomplain i x result y catch {rename foo ""} diff --git a/tests/appendComp.test b/tests/appendComp.test index f85c3ba..bbf5f9c 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -438,6 +438,27 @@ test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing } -cleanup { unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} + +test appendComp-10.1 {Bug 214cc0eb22: lappend with no values} { + apply {lst { + lappend lst + }} "# 1 2 3" +} "# 1 2 3" +test appendComp-10.2 {Bug 214cc0eb22: lappend with no values} -body { + apply {lst { + lappend lst + }} "1 \{ 2" +} -returnCodes error -result {unmatched open brace in list} +test appendComp-10.3 {Bug 214cc0eb22: expanded lappend with no values} { + apply {lst { + lappend lst {*}[list] + }} "# 1 2 3" +} "# 1 2 3" +test appendComp-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body { + apply {lst { + lappend lst {*}[list] + }} "1 \{ 2" +} -returnCodes error -result {unmatched open brace in list} catch {unset i x result y} catch {rename foo ""} 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 6c00508..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 @@ -2642,111 +2678,143 @@ test binary-73.23 {binary decode base64} -body { test binary-73.24 {binary decode base64} -body { string length [binary decode base64 " "] } -result 0 +test binary-73.25 {binary decode base64} -body { + list [string length [set r [binary decode base64 WA==\n]]] $r +} -result {1 X} +test binary-73.26 {binary decode base64} -body { + list [string length [set r [binary decode base64 WFk=\n]]] $r +} -result {2 XY} +test binary-73.27 {binary decode base64} -body { + list [string length [set r [binary decode base64 WFla\n]]] $r +} -result {3 XYZ} +test binary-73.28 {binary decode base64} -body { + list [string length [set r [binary decode base64 -strict WA==\n]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.29 {binary decode base64} -body { + list [string length [set r [binary decode base64 -strict WFk=\n]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.30 {binary decode base64} -body { + list [string length [set r [binary decode base64 -strict WFla\n]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.31 {binary decode base64} -body { + list [string length [set r [binary decode base64 WA==WFla]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} test binary-74.1 {binary encode uuencode} -body { binary encode uuencode } -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/chan.test b/tests/chan.test index da44ffd..d8390e2 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -61,7 +61,7 @@ test chan-4.5 {chan command: check valid inValue, invalid outValue} -body { } -returnCodes error -match glob -result {bad value for -eofchar:*} test chan-4.6 {chan command: check no inValue, valid outValue} -body { chan configure stdout -eofchar [list {} \x27] -} -returnCodes ok -result {} +} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]} test chan-5.1 {chan command: copy subcommand} -body { chan copy foo diff --git a/tests/chanio.test b/tests/chanio.test index 9bb11f7..2738fc6 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -13,10 +13,16 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2}]} { - chan puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* } + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint testbytestring [llength [info commands testbytestring]] + namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -40,11 +46,11 @@ namespace eval ::tcl::test::io { testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] - testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] + testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # You need a *very* special environment to do some tests. In particular, # many file systems do not support large-files... - testConstraint largefileSupport 0 + testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}] # some tests can only be run is umask is 2 if "umask" cannot be run, the # tests will be skipped. @@ -2214,13 +2220,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 +2240,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}} @@ -4516,10 +4526,10 @@ test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup { chan puts -nonewline $f abcdef lappend l [chan tell $f] chan close $f - lappend l [file size $f] + lappend l [file size $path(test3)] # truncate... chan close [open $path(test3) w] - lappend l [file size $f] + lappend l [file size $path(test3)] } -result {0 6 6 4294967296 4294967302 4294967302 0} # Test Tcl_Eof @@ -7422,11 +7432,11 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} { +test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] chan puts $out { - chan puts [encoding convertfrom identity \xe2] + chan puts [testbytestring \xe2] exit 1 } proc readit {pipe} { diff --git a/tests/clock.test b/tests/clock.test index 0202fc7..2abeab9 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -273,7 +273,7 @@ test clock-1.4 "clock format - bad flag" {*}{ list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode } -match glob - -result {1 {bad switch "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badSwitch -oops}} + -result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}} } test clock-1.5 "clock format - bad timezone" { @@ -35450,7 +35450,7 @@ test clock-33.2 {clock clicks tests} { } {1} test clock-33.3 {clock clicks tests} { list [catch {clock clicks foo} msg] $msg -} {1 {bad switch "foo": must be -milliseconds or -microseconds}} +} {1 {bad option "foo": must be -milliseconds or -microseconds}} test clock-33.4 {clock clicks tests} { expr [clock clicks -milliseconds]+1 concat {} @@ -35485,10 +35485,10 @@ test clock-33.5a {clock tests, millisecond timing test} { } {ok} test clock-33.6 {clock clicks, milli with too much abbreviation} { list [catch { clock clicks ? } msg] $msg -} {1 {bad switch "?": must be -milliseconds or -microseconds}} +} {1 {bad option "?": must be -milliseconds or -microseconds}} test clock-33.7 {clock clicks, milli with too much abbreviation} { list [catch { clock clicks - } msg] $msg -} {1 {ambiguous switch "-": must be -milliseconds or -microseconds}} +} {1 {ambiguous option "-": must be -milliseconds or -microseconds}} test clock-33.8 {clock clicks test, microsecond timing test} { # This test can fail on a system that is so heavily loaded that @@ -35607,7 +35607,7 @@ test clock-34.8 {clock scan tests} { } {Oct 23,1992 15:00 GMT} test clock-34.9 {clock scan tests} { list [catch {clock scan "Jan 12" -bad arg} msg] $msg -} {1 {bad switch "-bad", must be -base, -format, -gmt, -locale or -timezone}} +} {1 {bad option "-bad", must be -base, -format, -gmt, -locale or -timezone}} # The following two two tests test the two year date policy test clock-34.10 {clock scan tests} { set time [clock scan "1/1/71" -gmt true] @@ -36907,7 +36907,7 @@ test clock-65.1 {clock add, bad option [Bug 2481670]} {*}{ } -match glob -returnCodes error - -result {bad switch "-foo"*} + -result {bad option "-foo"*} } test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{ @@ -36927,6 +36927,15 @@ test clock-67.1 {clock format, %% with a letter following [Bug 2819334]} { clock format [clock seconds] -format %%r } %r +test clock-67.2 {Bug d19a30db57} -body { + # error, not segfault + tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222 +} -returnCodes error -match glob -result * +test clock-67.3 {Bug d19a30db57} -body { + # error, not segfault + tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222 +} -returnCodes error -match glob -result * + # cleanup namespace delete ::testClock diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 2ecf626..64cfeba 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -70,6 +70,12 @@ test cmdAH-1.2 {Tcl_CatchObjCmd, errors} { test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body { catch foo bar baz spaz } -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} +test cmdAH-1.4 {Bug 3595576} { + catch {catch {} -> noSuchNs::var} +} 1 +test cmdAH-1.5 {Bug 3595576} { + catch {catch error -> noSuchNs::var} +} 1 test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body { cd foo bar @@ -135,6 +141,9 @@ test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup { } -cleanup { cd $dir } -result {/} +test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -returnCodes error -body { + cd .\0 +} -result "couldn't change working directory to \".\0\": no such file or directory" test cmdAH-2.7 {Tcl_ConcatObjCmd} { concat } {} @@ -820,13 +829,13 @@ test cmdAH-16.1 {Tcl_FileObjCmd: readable} { } test cmdAH-16.2 {Tcl_FileObjCmd: readable} { -constraints testchmod - -setup {testchmod 0444 $gorpfile} + -setup {testchmod 0o444 $gorpfile} -body {file readable $gorpfile} -result 1 } test cmdAH-16.3 {Tcl_FileObjCmd: readable} { -constraints {unix notRoot testchmod} - -setup {testchmod 0333 $gorpfile} + -setup {testchmod 0o333 $gorpfile} -body {file readable $gorpfile} -result 0 } @@ -839,13 +848,13 @@ test cmdAH-17.1 {Tcl_FileObjCmd: writable} { } test cmdAH-17.2 {Tcl_FileObjCmd: writable} { -constraints {notRoot testchmod} - -setup {testchmod 0555 $gorpfile} + -setup {testchmod 0o555 $gorpfile} -body {file writable $gorpfile} -result 0 } test cmdAH-17.3 {Tcl_FileObjCmd: writable} { -constraints testchmod - -setup {testchmod 0222 $gorpfile} + -setup {testchmod 0o222 $gorpfile} -body {file writable $gorpfile} -result 1 } @@ -864,7 +873,7 @@ test cmdAH-18.2 {Tcl_FileObjCmd: executable} {notRoot} { test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} { # Only on unix will setting the execute bit on a regular file cause that # file to be executable. - testchmod 0775 $gorpfile + testchmod 0o775 $gorpfile file exe $gorpfile } 1 test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body { @@ -948,6 +957,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 efb0bce..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} { @@ -717,6 +726,16 @@ test cmdIL-7.8 {lreverse command - shared intrep [Bug 1675044]} -setup { rename K {} } -result 1 +# This belongs in info test, but adding tests there breaks tests +# that compute source file line numbers. +test info-20.6 {Bug 3587651} -setup { + namespace eval my {namespace eval tcl {namespace eval mathfunc { + proc demo x {return 42} + }}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup { + namespace delete my +} -result 1 + + # cleanup ::tcltest::cleanupTests return 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..d4a31d4 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 @@ -425,14 +455,22 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} { list [catch {exec [interpreter] << $script} msg] $msg } {0 OK} -# Special test for compiling tokens from a copy of the source string. [Bug -# 599788] +# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342] test compile-14.1 {testing errors in element name; segfault?} {} { catch {set a([error])} msg1 catch {set bubba([join $abba $jubba]) $vol} msg2 list $msg1 $msg2 } {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}} +test compile-14.2 {testing element name "$"} -body { + unset -nocomplain a + set a() 1 + set a(1) 2 + set a($) 3 + list [set a()] [set a(1)] [set a($)] [unset a() a(1); lindex [array names a] 0] +} -cleanup {unset a} -result [list 1 2 3 {$}] + + # Tests compile-15.* cover Tcl Bug 633204 test compile-15.1 {proper TCL_RETURN code from [return]} { apply {{} {catch return}} @@ -628,12 +666,15 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup # does not check the format of disassembled bytecode though; that's liable to # change without warning. +set disassemblables [linsert [join { + lambda method objmethod proc script +} ", "] end-1 or] test compile-18.1 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble } -match glob -result {wrong # args: should be "*"} test compile-18.2 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble ? -} -match glob -result {bad type "?": must be *} +} -result "bad type \"?\": must be $disassemblables" test compile-18.3 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble lambda } -match glob -result {wrong # args: should be "* lambda lambdaTerm"} @@ -707,6 +748,153 @@ test compile-18.19 {disassembler - basics} -setup { } -cleanup { foo destroy } -match glob -result * +# There never was a compile-18.20. +# The keys of the dictionary produced by [getbytecode] are defined. +set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth} +test compile-18.21 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode +} -match glob -result {wrong # args: should be "*"} +test compile-18.22 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode ? +} -result "bad type \"?\": must be $disassemblables" +test compile-18.23 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode lambda +} -match glob -result {wrong # args: should be "* lambda lambdaTerm"} +test compile-18.24 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode lambda \{ +} -result "can't interpret \"\{\" as a lambda expression" +test compile-18.25 {disassembler - basics} -body { + dict keys [tcl::unsupported::getbytecode lambda {{} {}}] +} -result $bytecodekeys +test compile-18.26 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode proc +} -match glob -result {wrong # args: should be "* proc procName"} +test compile-18.27 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode proc nosuchproc +} -result {"nosuchproc" isn't a procedure} +test compile-18.28 {disassembler - basics} -setup { + proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result $bytecodekeys +test compile-18.29 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode script +} -match glob -result {wrong # args: should be "* script script"} +test compile-18.30 {disassembler - basics} -body { + dict keys [tcl::unsupported::getbytecode script {}] +} -result $bytecodekeys +test compile-18.31 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method +} -match glob -result {wrong # args: should be "* method className methodName"} +test compile-18.32 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method nosuchclass foo +} -result {nosuchclass does not refer to an object} +test compile-18.33 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::getbytecode method justanobject foo +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.34 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.35 {disassembler - basics} -setup { + oo::class create foo {method bar {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode method foo bar] +} -cleanup { + foo destroy +} -result $bytecodekeys +test compile-18.36 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod +} -match glob -result {wrong # args: should be "* objmethod objectName methodName"} +test compile-18.37 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod nosuchobject foo +} -result {nosuchobject does not refer to an object} +test compile-18.38 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.39 {disassembler - basics} -setup { + oo::object create foo + oo::objdefine foo {method bar {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode objmethod foo bar] +} -cleanup { + foo destroy +} -result $bytecodekeys + +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..205da67 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -1,4 +1,4 @@ -# Commands covered: coroutine, yield, [info coroutine] +# Commands covered: coroutine, yield, yieldto, [info coroutine] # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files @@ -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,135 @@ 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 +test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.12 {coro floor above street level #3008307} -body { + proc c {} { + yield + } + proc cc {} { + coroutine C c + } + proc boom {} { + cc ; # coro created at level 2 + C ; # and called at level 1 + } + boom ; # does not crash: the coro floor is a good insulator + list +} -result {} + # 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 77bacf6..d5406d0 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -78,6 +78,24 @@ test dict-2.7 {dict create command - #-quoting in string rep} { test dict-2.8 {dict create command - #-quoting in string rep} -body { dict create #a x #b x } -match glob -result {{#?} x #? x} +test dict-2.9 {dict create command: compilation} { + apply {{} {dict create [format a] b}} +} {a b} +test dict-2.10 {dict create command: compilation} { + apply {{} {dict create [format a] b c d}} +} {a b c d} +test dict-2.11 {dict create command: compilation} { + apply {{} {dict create [format a] b c d a x}} +} {a x c d} +test dict-2.12 {dict create command: non-compilation} { + dict create [format a] b +} {a b} +test dict-2.13 {dict create command: non-compilation} { + dict create [format a] b c d +} {a b c d} +test dict-2.14 {dict create command: non-compilation} { + dict create [format a] b c d a x +} {a x c d} test dict-3.1 {dict get command} {dict get {a b} a} b test dict-3.2 {dict get command} {dict get {a b c d} a} b @@ -149,6 +167,51 @@ test dict-4.8 {dict replace command} -returnCodes error -body { } -result {missing value to go with key} test dict-4.9 {dict replace command} {dict replace [list a a] a b} {a b} test dict-4.10 {dict replace command} {dict replace [list a a] a b a c} {a c} +test dict-4.11 {dict replace command: canonicality is forced} { + dict replace { a b c d } +} {a b c d} +test dict-4.12 {dict replace command: canonicality is forced} { + dict replace {a b c d a e} +} {a e c d} +test dict-4.13 {dict replace command: type check is mandatory} -body { + dict replace { a b c d e } +} -returnCodes error -result {missing value to go with key} +test dict-4.13a {dict replace command: type check is mandatory} { + catch {dict replace { a b c d e }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY} +test dict-4.14 {dict replace command: type check is mandatory} -body { + dict replace { a b {}c d } +} -returnCodes error -result {dict element in braces followed by "c" instead of space} +test dict-4.14a {dict replace command: type check is mandatory} { + catch {dict replace { a b {}c d }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY JUNK} +test dict-4.15 {dict replace command: type check is mandatory} -body { + dict replace { a b ""c d } +} -returnCodes error -result {dict element in quotes followed by "c" instead of space} +test dict-4.15a {dict replace command: type check is mandatory} { + catch {dict replace { a b ""c d }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY JUNK} +test dict-4.16 {dict replace command: type check is mandatory} -body { + dict replace " a b \"c d " +} -returnCodes error -result {unmatched open quote in dict} +test dict-4.16a {dict replace command: type check is mandatory} { + catch {dict replace " a b \"c d "} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY QUOTE} +test dict-4.17 {dict replace command: type check is mandatory} -body { + dict replace " a b \{c d " +} -returnCodes error -result {unmatched open brace in dict} +test dict-4.17a {dict replace command: type check is mandatory} { + catch {dict replace " a b \{c d "} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY BRACE} +test dict-4.18 {dict replace command: canonicality forcing doesn't leak} { + set example { a b c d } + list $example [dict replace $example] +} {{ a b c d } {a b c d}} test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d} test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b} @@ -161,6 +224,25 @@ test dict-5.6 {dict remove command} {dict remove {a b} c} {a b} test dict-5.7 {dict remove command} -returnCodes error -body { dict remove } -result {wrong # args: should be "dict remove dictionary ?key ...?"} +test dict-5.8 {dict remove command: canonicality is forced} { + dict remove { a b c d } +} {a b c d} +test dict-5.9 {dict remove command: canonicality is forced} { + dict remove {a b c d a e} +} {a e c d} +test dict-5.10 {dict remove command: canonicality forced by update} { + dict remove { a b c d } c +} {a b} +test dict-5.11 {dict remove command: type check is mandatory} -body { + dict remove { a b c d e } +} -returnCodes error -result {missing value to go with key} +test dict-5.12 {dict remove command: type check is mandatory} -body { + dict remove { a b {}c d } +} -returnCodes error -result {dict element in braces followed by "c" instead of space} +test dict-5.13 {dict remove command: canonicality forcing doesn't leak} { + set example { a b c d } + list $example [dict remove $example] +} {{ a b c d } {a b c d}} test dict-6.1 {dict keys command} {dict keys {a b}} a test dict-6.2 {dict keys command} {dict keys {c d}} c @@ -327,13 +409,13 @@ test dict-11.13 {dict incr command} -returnCodes error -body { dict incr dictv a a a } -cleanup { unset dictv -} -result {wrong # args: should be "dict incr varName key ?increment?"} +} -result {wrong # args: should be "dict incr dictVarName key ?increment?"} test dict-11.14 {dict incr command} -returnCodes error -body { set dictv a dict incr dictv } -cleanup { unset dictv -} -result {wrong # args: should be "dict incr varName key ?increment?"} +} -result {wrong # args: should be "dict incr dictVarName key ?increment?"} test dict-11.15 {dict incr command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -404,10 +486,10 @@ test dict-12.6 {dict lappend command} -returnCodes error -body { } -result {missing value to go with key} test dict-12.7 {dict lappend command} -returnCodes error -body { dict lappend -} -result {wrong # args: should be "dict lappend varName key ?value ...?"} +} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"} test dict-12.8 {dict lappend command} -returnCodes error -body { dict lappend dictv -} -result {wrong # args: should be "dict lappend varName key ?value ...?"} +} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"} test dict-12.9 {dict lappend command} -returnCodes error -body { set dictv [dict create a "\{"] dict lappend dictv a a @@ -471,10 +553,10 @@ test dict-13.6 {dict append command} -returnCodes error -body { } -result {missing value to go with key} test dict-13.7 {dict append command} -returnCodes error -body { dict append -} -result {wrong # args: should be "dict append varName key ?value ...?"} +} -result {wrong # args: should be "dict append dictVarName key ?value ...?"} test dict-13.8 {dict append command} -returnCodes error -body { dict append dictv -} -result {wrong # args: should be "dict append varName key ?value ...?"} +} -result {wrong # args: should be "dict append dictVarName key ?value ...?"} test dict-13.9 {dict append command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -492,16 +574,16 @@ test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} { test dict-14.1 {dict for command: syntax} -returnCodes error -body { dict for -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.2 {dict for command: syntax} -returnCodes error -body { dict for x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.3 {dict for command: syntax} -returnCodes error -body { dict for x x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.4 {dict for command: syntax} -returnCodes error -body { dict for x x x x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.5 {dict for command: syntax} -returnCodes error -body { dict for x x x } -result {must have exactly two variable names} @@ -650,6 +732,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... @@ -713,13 +813,13 @@ test dict-15.9 {dict set command: write failure} -setup { } -result {can't set "dictVar": variable is array} test dict-15.10 {dict set command: syntax} -returnCodes error -body { dict set -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.11 {dict set command: syntax} -returnCodes error -body { dict set a -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.12 {dict set command: syntax} -returnCodes error -body { dict set a a -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.13 {dict set command} -returnCodes error -body { set dictVar a dict set dictVar b c @@ -772,7 +872,7 @@ test dict-16.7 {dict unset command} -setup { } -result {0 {} 1} test dict-16.8 {dict unset command} -returnCodes error -body { dict unset dictVar -} -result {wrong # args: should be "dict unset varName key ?key ...?"} +} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"} test dict-16.9 {dict unset command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -781,6 +881,55 @@ test dict-16.9 {dict unset command: write failure} -setup { } -returnCodes error -cleanup { unset dictVar } -result {can't set "dictVar": variable is array} +# Now test with an LVT present (i.e., the bytecoded version). +test dict-16.10 {dict unset command} -body { + apply {{} { + set dictVar {a b c d} + dict unset dictVar a + }} +} -result {c d} +test dict-16.11 {dict unset command} -body { + apply {{} { + set dictVar {a b c d} + dict unset dictVar c + }} +} -result {a b} +test dict-16.12 {dict unset command} -body { + apply {{} { + set dictVar {a b} + dict unset dictVar c + }} +} -result {a b} +test dict-16.13 {dict unset command} -body { + apply {{} { + set dictVar {a {b c d e}} + dict unset dictVar a b + }} +} -result {a {d e}} +test dict-16.14 {dict unset command} -returnCodes error -body { + apply {{} { + set dictVar a + dict unset dictVar a + }} +} -result {missing value to go with key} +test dict-16.15 {dict unset command} -returnCodes error -body { + apply {{} { + set dictVar {a b} + dict unset dictVar c d + }} +} -result {key "c" not known in dictionary} +test dict-16.16 {dict unset command} -body { + apply {{} {list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]}} +} -result {0 {} 1} +test dict-16.17 {dict unset command} -returnCodes error -body { + apply {{} {dict unset dictVar}} +} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"} +test dict-16.18 {dict unset command: write failure} -body { + apply {{} { + set dictVar(block) {} + dict unset dictVar a + }} +} -returnCodes error -result {can't set "dictVar": variable is array} test dict-17.1 {dict filter command: key} -body { set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} @@ -903,7 +1052,7 @@ test dict-17.17 {dict filter command: script} -body { } -result b test dict-17.18 {dict filter command: script} -returnCodes error -body { dict filter {a b} script {k k} -} -result {wrong # args: should be "dict filter dictionary script {keyVar valueVar} filterScript"} +} -result {wrong # args: should be "dict filter dictionary script {keyVarName valueVarName} filterScript"} test dict-17.19 {dict filter command: script} -returnCodes error -body { dict filter {a b} script k {continue} } -result {must have exactly two variable names} @@ -1111,19 +1260,64 @@ test dict-20.9 {dict merge command} { test dict-20.10 {dict merge command} { dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -} } {a - c d e f 1 - 3 4} +test dict-20.11 {dict merge command} { + apply {{} {dict merge}} +} {} +test dict-20.12 {dict merge command} { + apply {{} {dict merge {a b c d e f}}} +} {a b c d e f} +test dict-20.13 {dict merge command} -body { + apply {{} {dict merge {a b c d e}}} +} -result {missing value to go with key} -returnCodes error +test dict-20.14 {dict merge command} { + apply {{} {dict merge {a b c d} {e f g h}}} +} {a b c d e f g h} +test dict-20.15 {dict merge command} -body { + apply {{} {dict merge {a b c d e} {e f g h}}} +} -result {missing value to go with key} -returnCodes error +test dict-20.16 {dict merge command} -body { + apply {{} {dict merge {a b c d} {e f g h i}}} +} -result {missing value to go with key} -returnCodes error +test dict-20.17 {dict merge command} { + apply {{} {dict merge {a b c d e f} {e x g h}}} +} {a b c d e x g h} +test dict-20.18 {dict merge command} { + apply {{} {dict merge {a b c d} {a x c y}}} +} {a x c y} +test dict-20.19 {dict merge command} { + apply {{} {dict merge {a b c d} {c y a x}}} +} {a x c y} +test dict-20.20 {dict merge command} { + apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}} +} {a - c d e f 1 - 3 4} +test dict-20.21 {dict merge command: canonicality not forced} { + dict merge { a b c d } +} { a b c d } +test dict-20.22 {dict merge command: canonicality not forced} { + dict merge { a b c d } {} +} { a b c d } +test dict-20.23 {dict merge command: canonicality forced by update} { + dict merge { a b c d } {a b} +} {a b c d} +test dict-20.24 {dict merge command: type check is mandatory} -body { + dict merge { a b c d e } +} -returnCodes error -result {missing value to go with key} +test dict-20.25 {dict merge command: type check is mandatory} -body { + dict merge { a b {}c d } +} -returnCodes error -result {dict element in braces followed by "c" instead of space} test dict-21.1 {dict update command} -returnCodes 1 -body { dict update -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.2 {dict update command} -returnCodes 1 -body { dict update v -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.3 {dict update command} -returnCodes 1 -body { dict update v k -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.4 {dict update command} -returnCodes 1 -body { dict update v k v -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.5 {dict update command} -body { set a {b c} set result {} @@ -1261,10 +1455,10 @@ test dict-21.17 {dict update command: no recursive structures [Bug 1786481]} { test dict-22.1 {dict with command} -body { dict with -} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} +} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"} test dict-22.2 {dict with command} -body { dict with v -} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} +} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"} test dict-22.3 {dict with command} -body { unset -nocomplain v dict with v {error "in body"} @@ -1489,7 +1683,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 @@ -1521,6 +1715,339 @@ j }} [linenumber]}} } 5 rename linenumber {} + +test dict-24.1 {dict map command: syntax} -returnCodes error -body { + dict map +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} +test dict-24.2 {dict map command: syntax} -returnCodes error -body { + dict map x +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} +test dict-24.3 {dict map command: syntax} -returnCodes error -body { + dict map x x +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} +test dict-24.4 {dict map command: syntax} -returnCodes error -body { + dict map x x x x +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} +test dict-24.5 {dict map command: syntax} -returnCodes error -body { + dict map x x x +} -result {must have exactly two variable names} +test dict-24.6 {dict map command: syntax} -returnCodes error -body { + dict map {x x x} x x +} -result {must have exactly two variable names} +test dict-24.7 {dict map command: syntax} -returnCodes error -body { + dict map "\{x" x x +} -result {unmatched open brace in list} +test dict-24.8 {dict map command} -setup { + set values {} + set keys {} +} -body { + # This test confirms that [dict keys], [dict values] and [dict map] + # all traverse a dictionary in the same order. + set dictv {a A b B c C} + dict map {k v} $dictv { + lappend keys $k + lappend values $v + } + set result [expr { + $keys eq [dict keys $dictv] && $values eq [dict values $dictv] + }] + expr {$result ? "YES" : [list "NO" $dictv $keys $values]} +} -cleanup { + unset result keys values k v dictv +} -result YES +test dict-24.9 {dict map command} { + dict map {k v} {} { + error "unexpected execution of 'dict map' body" + } +} {} +test dict-24.10 {dict map command: script results} -body { + set times 0 + dict map {k v} {a a b b} { + incr times + continue + error "shouldn't get here" + } + return $times +} -cleanup { + unset times k v +} -result 2 +test dict-24.11 {dict map command: script results} -body { + set times 0 + dict map {k v} {a a b b} { + incr times + break + error "shouldn't get here" + } + return $times +} -cleanup { + unset times k v +} -result 1 +test dict-24.12 {dict map command: script results} -body { + set times 0 + list [catch { + dict map {k v} {a a b b} { + incr times + error test + } + } msg] $msg $times $::errorInfo +} -cleanup { + unset times k v msg +} -result {1 test 1 {test + while executing +"error test" + ("dict map" body line 3) + invoked from within +"dict map {k v} {a a b b} { + incr times + error test + }"}} +test dict-24.13 {dict map command: script results} { + apply {{} { + dict map {k v} {a b} { + return ok,$k,$v + error "skipped return completely" + } + error "return didn't go far enough" + }} +} ok,a,b +test dict-24.14 {dict map command: handle representation loss} -setup { + set keys {} + set values {} +} -body { + set dictVar {a b c d e f g h} + list [dict size [dict map {k v} $dictVar { + if {[llength $dictVar]} { + lappend keys $k + lappend values $v + return -level 0 $k + } + }]] [lsort $keys] [lsort $values] +} -cleanup { + unset dictVar keys values k v +} -result {4 {a c e g} {b d f h}} +test dict-24.14a {dict map command: handle representation loss} -body { + apply {{} { + set dictVar {a b c d e f g h} + list [dict size [dict map {k v} $dictVar { + if {[llength $dictVar]} { + lappend keys $k + lappend values $v + return -level 0 $k + } + }]] [lsort $keys] [lsort $values] + }} +} -result {4 {a c e g} {b d f h}} +test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup { + unset -nocomplain accum + array set accum {} +} -body { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + dict map {k v} $dictVar { + append accum($k) $v, + } + set result [lsort [array names accum]] + lappend result : + foreach k $result { + catch {lappend result $accum($k)} + } + return $result +} -cleanup { + unset dictVar k v result accum +} -result {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,} +test dict-24.16 {dict map command in compilation context} { + apply {{} { + set res {x x x x x x} + dict map {k v} {a 0 b 1 c 2 d 3 e 4 f 5} { + lset res $v $k + continue + } + return $res + }} +} {a b c d e f} +test dict-24.17 {dict map command in compilation context} { + # Bug 1379349 (dict for) + apply {{} { + set d [dict create a 1] ;# Dict must be unshared! + dict map {k v} $d { + dict set d $k 0 ;# Any modification will do + } + return $d + }} +} {a 0} +test dict-24.17a {dict map command in compilation context} { + # Bug 1379349 (dict for) + apply {{} { + set d [dict create a 1] ;# Dict must be unshared! + dict map {k v} $d { + dict set d $k 0 ;# Any modification will do + } + }} +} {a {a 0}} +test dict-24.18 {dict map command in compilation context} { + # Bug 1382528 (dict for) + apply {{} { + dict map {k v} {} {} ;# Note empty dict + catch { error foo } ;# Note compiled [catch] + }} +} 1 +test dict-24.19 {dict map and invalid dicts: 'dict for' bug 1531184} -body { + di[list]ct map {k v} x {} +} -returnCodes 1 -result {missing value to go with key} +test dict-24.20 {dict map stack space compilation: 'dict for' bug 1903325} { + apply {{x y args} { + dict map {a b} $x {} + concat "c=$y,$args" + }} {} 1 2 3 +} {c=1,2 3} +proc linenumber {} { + dict get [info frame -1] line +} +test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} { + apply {{} {apply {n { + set e {} + set k {} + dict map {a b} {c {d {e {f g}}}} { + ::tcl::dict::map {h i} $b { + dict update i e j { + ::tcl::dict::update j f k { + return [expr {$n - [linenumber]}] + } + } + } + } + }} [linenumber]}} +} 5 +test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} { + apply {{} {apply {n { + set e {} + set k {} + dict map {a { +b +}} {c {d {e {f g}}}} { + ::tcl::dict::map {h { +i +}} ${ +b +} { + dict update { +i +} e { +j +} { + ::tcl::dict::update { +j +} f k { + return [expr {$n - [linenumber]}] + } + } + } + } + }} [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 }] { + return -level 0 "$k,$v" + } +} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} +test dict-24.23 {dict map results (compiled)} { + apply {{} { + dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { + return -level 0 "$k,$v" + } + }} +} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} +test dict-24.23a {dict map results (compiled)} { + apply {{list} { + dict map {k v} [dict map {k v} $list { list $v $k }] { + return -level 0 "$k,$v" + } + }} {a 1 b 2 c 3 d 4} +} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} +test dict-24.24 {dict map with huge dict (non-compiled)} { + tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 100000 x] x] { + expr { $k * $v } + }] +} 166666666600000 +test dict-24.25 {dict map with huge dict (compiled)} { + apply {{n} { + tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat $n y] y] { + expr { $k * $v } + }] + }} 100000 +} 166666666600000 + # cleanup ::tcltest::cleanupTests 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..af07ed7 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 } @@ -1040,6 +1184,12 @@ test error-21.8 {memory leaks in try: Bug 2910044} memory { } } 0 +test error-21.9 {Bug cee90e4e88} { + # Just don't panic. + apply {{} {try {} on ok {} - on return {} {}}} +} {} + + # negative case try tests - bad "trap" handler # what is the effect if we attempt to trap an errorcode that is not a list? # nested try diff --git a/tests/exec.test b/tests/exec.test index 64d3517..16a8320 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] } @@ -370,7 +370,7 @@ err} test exec-10.1 {errors in exec invocation} -constraints {exec} -body { exec -} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"} +} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"} test exec-10.2 {errors in exec invocation} -constraints {exec} -body { exec | cat } -returnCodes error -result {illegal use of | or |& in command} @@ -545,10 +545,10 @@ test exec-14.1 {-keepnewline switch} {exec} { } "foo\n" test exec-14.2 {-keepnewline switch} -constraints {exec} -body { exec -keepnewline -} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"} +} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"} test exec-14.3 {unknown switch} -constraints {exec} -body { exec -gorp -} -returnCodes error -result {bad switch "-gorp": must be -ignorestderr, -keepnewline, or --} +} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --} test exec-14.4 {-- switch} -constraints {exec} -body { exec -- -gorp } -returnCodes error -result {couldn't execute "-gorp": no such file or directory} 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..c8264b2 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -128,7 +128,7 @@ proc checkcontent {file matchString} { } proc openup {path} { - testchmod 777 $path + testchmod 0o777 $path if {[file isdirectory $path]} { catch { foreach p [glob -directory $path *] { @@ -362,10 +362,10 @@ test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} -setup { cleanup } -constraints {unix notRoot testchmod} -returnCodes error -body { file mkdir td1/td2/td3 - testchmod 000 td1/td2 + testchmod 0 td1/td2 file mkdir td1/td2/td3/td4 } -cleanup { - testchmod 755 td1/td2 + testchmod 0o755 td1/td2 cleanup } -result {can't create directory "td1/td2/td3": permission denied} test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} -setup { @@ -505,18 +505,12 @@ test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} -setup { cleanup } -constraints {unix notRoot testchmod} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 createfile tf1 file rename tf1 td1 } -returnCodes error -cleanup { - testchmod 755 td1 + testchmod 0o755 td1 } -result {error renaming "tf1" to "td1/tf1": permission denied} -test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} -setup { - cleanup -} -constraints {win 95} -returnCodes error -body { - createfile tf1 - file rename tf1 $long -} -result [subst {error renaming "tf1" to "$long": file name too long}] test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup { cleanup } -constraints {unix notRoot} -body { @@ -791,7 +785,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 createfile tf2 - testchmod 444 tf2 + testchmod 0o444 tf2 file rename tf1 tf3 file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] @@ -800,7 +794,7 @@ test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup { cleanup } -constraints {win win2000orXP testchmod} -body { file mkdir td1 td2 - testchmod 555 td2 + testchmod 0o555 td2 file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] @@ -811,7 +805,7 @@ test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup { cleanup } -constraints {unix notRoot testchmod notDarwin9} -body { file mkdir td1 td2 - testchmod 555 td2 + testchmod 0o555 td2 file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] @@ -823,7 +817,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 444 tf2 + testchmod 0o444 tf2 file rename -force tf1 tf1 file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] @@ -833,7 +827,7 @@ test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup { } -constraints {win win2000orXP testchmod} -body { file mkdir td1 file mkdir td2 - testchmod 555 td2 + testchmod 0o555 td2 file rename -force td1 . file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] @@ -843,7 +837,7 @@ test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup { } -constraints {unix notRoot testchmod} -body { file mkdir td1 file mkdir td2 - testchmod 555 td2 + testchmod 0o555 td2 file rename -force td1 . file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] @@ -861,10 +855,10 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup { createfile tfd2 createfile tfd3 createfile tfd4 - testchmod 444 tfs3 - testchmod 444 tfs4 - testchmod 444 tfd2 - testchmod 444 tfd4 + testchmod 0o444 tfs3 + testchmod 0o444 tfs4 + testchmod 0o444 tfd2 + testchmod 0o444 tfd4 set msg [list [catch {file rename tf1 tf2} msg] $msg] file rename -force tfs1 tfd1 file rename -force tfs2 tfd2 @@ -888,11 +882,11 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] if {![testConstraint unix]} { - testchmod 555 tds3 - testchmod 555 tds4 + testchmod 0o555 tds3 + testchmod 0o555 tds4 } - testchmod 555 [file join tdd2 tds2] - testchmod 555 [file join tdd4 tds4] + testchmod 0o555 [file join tdd2 tds2] + testchmod 0o555 [file join tdd4 tds4] set msg [list [catch {file rename td1 td2} msg] $msg] file rename -force tds1 tdd1 file rename -force tds2 tdd2 @@ -917,7 +911,7 @@ test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup { file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] if {!([testConstraint unix] || [testConstraint winVista])} { - testchmod 555 tds2 + testchmod 0o555 tds2 } set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] @@ -935,7 +929,7 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} -setup { createfile tf1 createfile tf2 file mkdir td1 - testchmod 444 tf2 + testchmod 0o444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \ @@ -948,7 +942,7 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td2 file mkdir td3 if {!([testConstraint unix] || [testConstraint winVista])} { - testchmod 555 td2 + testchmod 0o555 td2 } file rename td1 [file join td3 td3] file rename td2 [file join td3 td4] @@ -964,13 +958,13 @@ test fCmd-9.12 {file rename: comprehensive: target exists} -setup { cleanup } -constraints {notRoot testchmod notNetworkFilesystem} -body { file mkdir [file join td1 td2] [file join td2 td1] - testchmod 555 [file join td2 td1] + testchmod 0o555 [file join td2 td1] file mkdir [file join td3 td4] [file join td4 td3] file rename -force td3 td4 list [file exists td3] [file exists [file join td4 td3 td4]] \ [catch {file rename td1 td2} msg] $msg } -cleanup { - testchmod 755 [file join td2 td1] + testchmod 0o755 [file join td2 td1] } -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] # Test can hit EEXIST or EBUSY, depending on underlying filesystem test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup { @@ -1041,7 +1035,7 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 444 tf2 + testchmod 0o444 tf2 file copy tf1 tf3 file copy tf2 tf4 list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4] @@ -1051,14 +1045,14 @@ test fCmd-10.3 {file copy: comprehensive: dir to new name} -setup { } -constraints {unix notRoot testchmod} -body { file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] - testchmod 555 td2 + testchmod 0o555 td2 file copy td1 td3 file copy td2 td4 list [lsort [glob td*]] [glob -directory td3 t*] \ [glob -directory td4 t*] [file writable td3] [file writable td4] } -cleanup { - testchmod 755 td2 - testchmod 755 td4 + testchmod 0o755 td2 + testchmod 0o755 td4 } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0] test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { cleanup @@ -1066,14 +1060,14 @@ test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { # On Windows with ACLs, copying a directory is defined like this file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] - testchmod 555 td2 + testchmod 0o555 td2 file copy td1 td3 file copy td2 td4 list [lsort [glob td*]] [glob -directory td3 t*] \ [glob -directory td4 t*] [file writable td3] [file writable td4] } -cleanup { - testchmod 755 td2 - testchmod 755 td4 + testchmod 0o755 td2 + testchmod 0o755 td4 } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1] test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { cleanup @@ -1088,10 +1082,10 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { createfile tfd2 createfile tfd3 createfile tfd4 - testchmod 444 tfs3 - testchmod 444 tfs4 - testchmod 444 tfd2 - testchmod 444 tfd4 + testchmod 0o444 tfs3 + testchmod 0o444 tfs4 + testchmod 0o444 tfd2 + testchmod 0o444 tfd4 set msg [list [catch {file copy tf1 tf2} msg] $msg] file copy -force tfs1 tfd1 file copy -force tfs2 tfd2 @@ -1112,10 +1106,10 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup { file mkdir [file join tdd2 tds2] file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] - testchmod 555 tds3 - testchmod 555 tds4 - testchmod 555 [file join tdd2 tds2] - testchmod 555 [file join tdd4 tds4] + testchmod 0o555 tds3 + testchmod 0o555 tds4 + testchmod 0o555 [file join tdd2 tds2] + testchmod 0o555 [file join tdd4 tds4] set a1 [list [catch {file copy td1 td2} msg] $msg] set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a3 [catch {file copy -force tds2 tdd2}] @@ -1130,7 +1124,7 @@ test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup { file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] - testchmod 555 tds2 + testchmod 0o555 tds2 set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] @@ -1141,7 +1135,7 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} -setup { createfile tf1 createfile tf2 file mkdir td1 - testchmod 444 tf2 + testchmod 0o444 tf2 file copy tf1 [file join td1 tf3] file copy tf2 [file join td1 tf4] list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \ @@ -1153,7 +1147,7 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td1 file mkdir td2 file mkdir td3 - testchmod 555 td2 + testchmod 0o555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ @@ -1166,7 +1160,7 @@ test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td1 file mkdir td2 file mkdir td3 - testchmod 555 td2 + testchmod 0o555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ @@ -2330,10 +2324,10 @@ test fCmd-28.2 {file link} -returnCodes error -body { } -result {wrong # args: should be "file link ?-linktype? linkname ?target?"} test fCmd-28.3 {file link} -returnCodes error -body { file link abc b c -} -result {bad switch "abc": must be -symbolic or -hard} +} -result {bad option "abc": must be -symbolic or -hard} test fCmd-28.4 {file link} -returnCodes error -body { file link -abc b c -} -result {bad switch "-abc": must be -symbolic or -hard} +} -result {bad option "-abc": must be -symbolic or -hard} cd [workingDirectory] makeDirectory abc.dir makeDirectory abc2.dir @@ -2441,14 +2435,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 +2466,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 +2477,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 +2497,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/fileName.test b/tests/fileName.test index 6dd1cb4..51f00d1 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -749,7 +749,7 @@ test filename-11.13 {Tcl_GlobCmd} { } [file join $env(HOME)] set oldpwd [pwd] set oldhome $env(HOME) -cd [temporaryDirectory] +catch {cd [makeDirectory tcl[pid]]} set env(HOME) [pwd] file delete -force globTest file mkdir globTest/a1/b1 @@ -1616,6 +1616,7 @@ catch {file delete -force C:/globTest} cd [temporaryDirectory] file delete -force globTest cd $oldpwd +catch {removeDirectory tcl[pid]} set env(HOME) $oldhome if {[testConstraint testsetplatform]} { testsetplatform $platform diff --git a/tests/fileSystem.test b/tests/fileSystem.test index b098f35..9fe4fe9 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} @@ -504,6 +513,9 @@ test filesystem-6.32 {empty file name} -returnCodes error -body { file type "" } -result {could not read "": no such file or directory} test filesystem-6.33 {empty file name} {file writable ""} 0 +test filesystem-6.34 {file name with (invalid) nul character} { + list [catch "open foo\x00" msg] $msg +} [list 1 "couldn't open \"foo\x00\": filename is invalid on this platform"] # Make sure the testfilesystem hasn't been registered. if {[testConstraint testfilesystem]} { @@ -632,7 +644,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 +669,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 a4b652a..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} @@ -266,6 +277,15 @@ test foreach-10.1 {foreach: [Bug 1671087]} -setup { rename demo {} } -result {} +test foreach-11.1 {error then dereference loop var (dev bug)} { + catch { foreach a 0 b {1 2 3} { error x } } + set a +} 0 +test foreach-11.2 {error then dereference loop var (dev bug)} { + catch { foreach a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 + # cleanup catch {unset a} catch {unset x} diff --git a/tests/http.test b/tests/http.test index bde5795..41820cb 100644 --- a/tests/http.test +++ b/tests/http.test @@ -51,7 +51,7 @@ if {![file exists $httpdFile]} { set removeHttpd 1 } -catch {package require Thread 2.6} +catch {package require Thread 2.7-} if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { set httpthread [thread::create -preserved] thread::send $httpthread [list source $httpdFile] @@ -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] @@ -305,7 +306,6 @@ test http-3.13 {http::geturl socket leak test} { for {set i 0} {$i < 3} {incr i} { catch {http::geturl $badurl -timeout 5000} } - # No extra channels should be taken expr {[llength [file channels]] == $chanCount} } 1 @@ -371,11 +371,11 @@ test http-3.27 {http::geturl: -headers override -type} -body { http::data $token } -cleanup { http::cleanup $token -} -match regexp -result {(?n)Accept \*/\* -Host .* +} -match regexp -result {(?n)Host .* User-Agent .* Connection close Content-Type {text/plain;charset=utf-8} +Accept \*/\* Accept-Encoding .* Content-Length 5} test http-3.28 {http::geturl: -headers override -type default} -body { @@ -384,14 +384,14 @@ test http-3.28 {http::geturl: -headers override -type default} -body { http::data $token } -cleanup { http::cleanup $token -} -match regexp -result {(?n)Accept \*/\* -Host .* +} -match regexp -result {(?n)Host .* User-Agent .* Connection close Content-Type {text/plain;charset=utf-8} +Accept \*/\* 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,6 +405,32 @@ 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 +# Bug c11a51c482 +test http-3.32 {http::geturl: -headers override -accept default} -body { + set token [http::geturl $url/headers -query dummy \ + -headers [list "Accept" "text/plain,application/tcl-test-value"]] + http::data $token +} -cleanup { + http::cleanup $token +} -match regexp -result {(?n)Host .* +User-Agent .* +Connection close +Accept text/plain,application/tcl-test-value +Accept-Encoding .* +Content-Type application/x-www-form-urlencoded +Content-Length 5} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] @@ -480,14 +506,10 @@ proc myProgress {token total current} { } set progress [list $total $current] } -if 0 { - # This test hangs on Windows95 because the client never gets EOF - set httpLog 1 - test http-4.6.1 {http::Event} knownBug { - set token [http::geturl $url -blocksize 50 -progress myProgress] - return $progress - } {111 111} -} +test http-4.6.1 {http::Event} knownBug { + set token [http::geturl $url -blocksize 50 -progress myProgress] + return $progress +} {111 111} test http-4.7 {http::Event} -body { set token [http::geturl $url -keepalive 0 -progress myProgress] return $progress @@ -547,11 +569,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/http11.test b/tests/http11.test index 230ce5a..c9ded0b 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -70,11 +70,8 @@ proc check_crc {tok args} { return "ok" } -makeFile "<html><head><title>test</title></head>\ -<body><p>this is a test</p>\n\ -[string repeat {<p>This is a tcl test file.</p>} 4192]\n\ -</body></html>" testdoc.html - +makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html + # ------------------------------------------------------------------------- test http11-1.0 "normal request for document " -setup { @@ -447,7 +444,8 @@ test http11-2.10 "-channel,deflate,keepalive" -setup { set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ - -timeout 5000 -channel $chan -keepalive 1] + -timeout 5000 -channel $chan -keepalive 1 \ + -headers {accept-encoding deflate}] http::wait $tok seek $chan 0 set data [read $chan] @@ -482,6 +480,27 @@ test http11-2.11 "-channel,identity,keepalive" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} {} chunked} +test http11-2.12 "-channel,negotiate,keepalive" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan -keepalive 1] + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] [meta $tok x-requested-encodings]\ + [expr {[file size testdoc.html]-[file size testfile.tmp]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0} + + # ------------------------------------------------------------------------- # # The following tests for the -handler option will require changes in @@ -644,7 +663,7 @@ test http11-4.3 "normal post request, check channel query length" -setup { removeFile testfile.tmp halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880} - + # ------------------------------------------------------------------------- foreach p {create_httpd httpd_read halt_httpd meta check_crc} { 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/httpd11.tcl b/tests/httpd11.tcl index 9c543dc..267f409 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -158,13 +158,13 @@ proc Service {chan addr port} { } if {$protocol eq "HTTP/1.1"} { - if {[string match "*deflate*" [dict get? $meta accept-encoding]]} { - set encoding deflate - } elseif {[string match "*gzip*" [dict get? $meta accept-encoding]]} { - set encoding gzip - } elseif {[string match "*compress*" [dict get? $meta accept-encoding]]} { - set encoding compress - } + foreach enc [split [dict get? $meta accept-encoding] ,] { + set enc [string trim $enc] + if {$enc in {deflate gzip compress}} { + set encoding $enc + break + } + } set transfer chunked } else { set close 1 @@ -189,6 +189,7 @@ proc Service {chan addr port} { if {$close} { Puts $chan "connection: close" } + Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]" if {$encoding eq "identity"} { Puts $chan "content-length: [string length $data]" } else { diff --git a/tests/info.test b/tests/info.test index 7dd63b7..3057dd2 100644 --- a/tests/info.test +++ b/tests/info.test @@ -692,31 +692,31 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body { ## # ### ### ### ######### ######### ######### ## info frame + ## Helper # For the more complex results we cut the file name down to remove path # dependencies, and we use only part of the first line of the reported # command. The latter is required because otherwise the whole test case may # appear in some results, but the result is part of the testcase. An infinite # string would be required to describe that. The cutting-down breaks this. + proc reduce {frame} { - set pos [lsearch -exact $frame cmd] - incr pos - set cmd [lindex $frame $pos] + set cmd [dict get $frame cmd] if {[regexp \n $cmd]} { - set first [string range [lindex [split $cmd \n] 0] 0 end-4] - set frame [lreplace $frame $pos $pos $first] + dict set frame cmd \ + [string range [lindex [split $cmd \n] 0] 0 end-4] } - set pos [lsearch -exact $frame file] - if {$pos >=0} { - incr pos - set tail [file tail [lindex $frame $pos]] - set frame [lreplace $frame $pos $pos $tail] + if {[dict exists $frame file]} { + dict set frame file \ + [file tail [dict get $frame file]] } - set frame + return $frame } + proc subinterp {} { interp create sub ; interp debug sub -frame 1; interp eval sub [list proc reduce [info args reduce] [info body reduce]] } + ## Helper # Generate a stacktrace from the current location to top. This code # not only depends on the exact location of things, but also on the @@ -1454,9 +1454,9 @@ test info-30.1 {bs+nl in literal words, procedure body, compiled} -body { test info-30.2 {bs+nl in literal words, namespace script} { namespace eval xxx { variable res \ - [reduce [info frame 0]];# line 1457 + [info frame 0];# line 1457 } - return $xxx::res + return [reduce $xxx::res] } {type source line 1457 file info.test cmd {info frame 0} level 0} test info-30.3 {bs+nl in literal words, namespace multi-word script} { @@ -1955,6 +1955,446 @@ test info-38.2 {location information for uplevel, dl, direct-literal} -match glo * {type source line 1951 file info.test cmd etrace level 1} * {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub} +# This test at the end of this file _only_ to avoid disturbing above line +# numbers. It _belongs_ after info-9.12 +test info-9.13 {info level option, value in global context} -body { + uplevel #0 {info level 2} +} -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 diff --git a/tests/interp.test b/tests/interp.test index 0af9887..4bc9fe2 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 {} @@ -3601,10 +3615,10 @@ test interp-38.3 {interp debug wrong args} -body { } -returnCodes { error } -result {wrong # args: should be "interp debug path ?-frame ?bool??"} -test interp-38.4 {interp debug basic setup} -body { +test interp-38.4 {interp debug basic setup} -constraints {!singleTestInterp} -body { interp debug {} } -result {-frame 0} -test interp-38.5 {interp debug basic setup} -body { +test interp-38.5 {interp debug basic setup} -constraints {!singleTestInterp} -body { interp debug {} -f } -result {0} test interp-38.6 {interp debug basic setup} -body { diff --git a/tests/io.test b/tests/io.test index 9621138..6b6ad6d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -13,14 +13,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +testConstraint testbytestring [llength [info commands testbytestring]] + namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -41,11 +43,11 @@ testConstraint fcopy [llength [info commands fcopy]] testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... -testConstraint largefileSupport 0 +testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}] # some tests can only be run is umask is 2 # if "umask" cannot be run, the tests will be skipped. @@ -1449,6 +1451,105 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee lappend x [catch {close $f} msg] $msg set x } "{} timeout {} timeout \u7266 {} eof 0 {}" +test io-12.6 {ReadChars: too many chars read} { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat \uBEEF 20][string repeat . 20]] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 + while {![eof $c]} { + read $c 15 + } + close $c +} {} +test io-12.7 {ReadChars: too many chars read [bc5b790099]} { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat \uBEEF 10]....\uBEEF] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 + while {![eof $c]} { + read $c 7 + } + close $c +} {} +test io-12.8 {ReadChars: multibyte chars split} { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xc2\xa0 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -buffersize 10 + set in [read $f] + close $f + scan [string index $in end] %c +} 160 +test io-12.9 {ReadChars: multibyte chars split} { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xc2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -buffersize 10 + set in [read $f] + close $f + scan [string index $in end] %c +} 194 +test io-12.10 {ReadChars: multibyte chars split} { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xc2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -buffersize 11 + set in [read $f] + close $f + scan [string index $in end] %c +} 194 test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] @@ -1563,6 +1664,45 @@ test io-13.8 {TranslateInputEOL: auto mode: \r\n} { close $f set x } "abcd\ndef" +test io-13.8.1 {TranslateInputEOL: auto mode: \r\n} { + set f [open $path(test1) w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef" + close $f + set f [open $path(test1)] + fconfigure $f -translation auto + set x {} + lappend x [read $f 5] + lappend x [read $f] + close $f + set x +} [list "abcd\n" "def"] +test io-13.8.2 {TranslateInputEOL: auto mode: \r\n} { + set f [open $path(test1) w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\ndef" + close $f + set f [open $path(test1)] + fconfigure $f -translation auto -buffersize 6 + set x {} + lappend x [read $f 5] + lappend x [read $f] + close $f + set x +} [list "abcd\n" "def"] +test io-13.8.3 {TranslateInputEOL: auto mode: \r\n} { + set f [open $path(test1) w] + fconfigure $f -translation lf + puts -nonewline $f "abcd\r\n\r\ndef" + close $f + set f [open $path(test1)] + fconfigure $f -translation auto -buffersize 7 + set x {} + lappend x [read $f 5] + lappend x [read $f] + close $f + set x +} [list "abcd\n" "\ndef"] test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { set f [open $path(test1) w] fconfigure $f -translation lf @@ -2771,7 +2911,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa variable x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz proc writelots {s l} { - for {set i 0} {$i < 2000} {incr i} { + for {set i 0} {$i < 9000} {incr i} { puts $s $l } } @@ -2802,7 +2942,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa close $ss vwait [namespace which -variable x] set c -} 2000 +} 9000 test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} { # On Mac, this test screws up sockets such that subsequent tests using port 2828 # either cause errors or panic(). @@ -3984,6 +4124,46 @@ test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { } {{hello } {hello }} +test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts $f1 {chan configure stdout -translation crlf} + puts $f1 {puts [gets stdin]} + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + puts $f1 hello + flush $f1 + set x "" + lappend x [read $f1 6] + puts $f1 hello + flush $f1 + lappend x [read $f1] + close $f1 + set x +} {{hello +} {hello +}} +test io-32.11.2 {Tcl_Read from a pipe} {stdio openpipe} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts $f1 {chan configure stdout -translation crlf} + puts $f1 {puts [gets stdin]} + puts $f1 {puts [gets stdin]} + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + puts $f1 hello + flush $f1 + set x "" + lappend x [read $f1 6] + puts $f1 hello + flush $f1 + lappend x [read $f1] + close $f1 + set x +} {{hello +} {hello +}} test io-32.12 {Tcl_Read, -nonewline} { file delete $path(test1) set f1 [open $path(test1) w] @@ -4178,6 +4358,110 @@ test io-33.10 {Tcl_Gets, exercising double buffering} { close $f set y } 300 +test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 3} {set n 3} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -translation binary -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result {{} {} {} .......} +test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ....... + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 3} {set n 3} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result {{} {} {} .......} +test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [string repeat \ + [string repeat . 64]\n[string repeat . 25] 2] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {$n > 65} {set n 65} + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } +} -body { + set c [chan create read [namespace which driver]] + chan configure $c -blocking 0 + list [gets $c] [gets $c] [gets $c] [gets $c] [gets $c] +} -cleanup { + close $c + rename driver {} +} -result [list [string repeat . 64] {} [string repeat . 89] \ + [string repeat . 25] {}] # Test Tcl_Seek and Tcl_Tell. @@ -4457,10 +4741,10 @@ test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { puts -nonewline $f abcdef lappend l [tell $f] close $f - lappend l [file size $f] + lappend l [file size $path(test3)] # truncate... close [open $path(test3) w] - lappend l [file size $f] + lappend l [file size $path(test3)] set l } {0 6 6 4294967296 4294967302 4294967302 0} @@ -4725,6 +5009,92 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { close $f list $c $l $e } {21 8 1} +test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr + puts $f abc\ndef + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {8 8 1 13} +test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar \x1a + puts $f abc\ndef + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {9 8 1 13} +test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar \x1a + puts $f {} + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {2 1 1 13} +test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr + puts $f {} + close $f + set s [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $s $l $e [scan [string index $in end] %c] +} -result {1 1 1 13} +test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar {} + set i [format abc\ndef\n%cqrs\nuvw 26] + puts $f $i + close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $c $l $e [scan [string index $in end] %c] +} -result {17 8 1 13} +test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} { + file delete $path(test1) + set f [open $path(test1) w] + fconfigure $f -translation cr -eofchar {} + set i [format \n%cqrsuvw 26] + puts $f $i + close $f + set c [file size $path(test1)] + set f [open $path(test1) r] + fconfigure $f -translation crlf -eofchar \x1a + set l [string length [set in [read $f]]] + set e [eof $f] + close $f + list $c $l $e [scan [string index $in end] %c] +} {9 1 1 13} # Test Tcl_InputBlocked @@ -4747,6 +5117,29 @@ test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { close $f1 set x } {{} 1 hello 0 {} 1} +test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} {stdio openpipe} { + set f1 [open "|[list [interpreter]]" r+] + chan configure $f1 -encoding binary -translation lf -eofchar {} + puts $f1 { + chan configure stdout -encoding binary -translation lf -eofchar {} + puts hello_from_pipe + } + flush $f1 + gets $f1 + fconfigure $f1 -blocking off -buffering full + puts $f1 {puts hello} + set x "" + lappend x [gets $f1] + lappend x [fblocked $f1] + flush $f1 + after 200 + lappend x [gets $f1] + lappend x [fblocked $f1] + lappend x [gets $f1] + lappend x [fblocked $f1] + close $f1 + set x +} {{} 1 hello 0 {} 1} test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { set f1 [open "|[list [interpreter]]" r+] fconfigure $f1 -buffering line @@ -6564,11 +6957,23 @@ test io-52.4 {TclCopyChannel} {fcopy} { fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation cr -blocking 0 fcopy $f1 $f2 -size 40 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + lappend result [file size $path(test1)] +} {0 0 0 40} +test io-52.4.1 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + fconfigure $f1 -translation lf -blocking 0 -buffersize 10000000 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -size 40 + set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 close $f2 lappend result [file size $path(test1)] -} {0 0 40} +} {0 0 0 40} test io-52.5 {TclCopyChannel, all} {fcopy} { file delete $path(test1) set f1 [open $thisScript] @@ -6754,6 +7159,150 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} { file size $path(kyrillic.txt) } 3 +test io-52.12 {coverage of -translation auto} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 + set out [open $path(test2) w] + chan configure $out -translation lf + fcopy $in $out + close $in + close $out + file size $path(test2) +} 29 +test io-52.13 {coverage of -translation cr} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation cr + set out [open $path(test2) w] + chan configure $out -translation lf + fcopy $in $out + close $in + close $out + file size $path(test2) +} 30 +test io-52.14 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + chan configure $out -translation lf + fcopy $in $out + close $in + close $out + file size $path(test2) +} 29 +test io-52.14.1 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + fcopy $in $out -size 2 + close $in + close $out + file size $path(test2) +} 2 +test io-52.14.2 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -translation crlf + set out [open $path(test2) w] + fcopy $in $out -size 9 + close $in + close $out + file size $path(test2) +} 9 +test io-52.15 {coverage of -translation crlf} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\r + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 +test io-52.16 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation lf -eofchar a + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 0 +test io-52.17 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation lf -eofchar d + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 3 +test io-52.18 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 8 -translation crlf -eofchar h + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 +test io-52.19 {coverage of eofChar handling} { + file delete $path(test1) $path(test2) + set out [open $path(test1) wb] + chan configure $out -translation lf + puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz + close $out + set in [open $path(test1)] + chan configure $in -buffersize 10 -translation crlf -eofchar h + set out [open $path(test2) w] + fcopy $in $out + close $in + close $out + file size $path(test2) +} 8 + test io-53.1 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] @@ -6823,17 +7372,12 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven for {set x 0} {$x < 12} {incr x} { append big $big } - file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { puts ready fcopy stdin stdout -command { set x } vwait x - set f [open $path(test1) w] - fconfigure $f -translation lf - puts $f "done" - close $f } close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] @@ -6841,11 +7385,10 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven fconfigure $f1 -blocking 0 puts $f1 $big flush $f1 - after 500 set result "" fileevent $f1 read [namespace code { append result [read $f1 1024] - if {[string length $result] >= [string length $big]} { + if {[string length $result] >= [string length $big]+1} { set x done } }] @@ -6854,6 +7397,38 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven set big {} set x } done +test io-53.4.1 {Bug 894da183c8} {stdio fcopy} { + set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n + variable x + for {set x 0} {$x < 12} {incr x} { + append big $big + } + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts $f1 [list file delete $path(test1)] + puts $f1 { + puts ready + set f [open io-53.4.1 w] + chan configure $f -translation lf + fcopy stdin $f -command { set x } + vwait x + close $f + } + puts $f1 "close \[[list open $path(test1) w]]" + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set result [gets $f1] + fconfigure $f1 -blocking 0 -buffersize 125000 -translation lf + puts $f1 $big + fconfigure $f1 -blocking 1 + close $f1 + set big {} + while {[catch {glob $path(test1)}]} {after 50} + file delete $path(test1) + set check [file size io-53.4.1] + file delete io-53.4.1 + set check +} 266241 set result {} proc FcopyTestAccept {sock args} { after 1000 "close $sock" @@ -7223,6 +7798,211 @@ test io-53.11 {Bug 2895565} -setup { removeFile out removeFile in } -result {40 bytes copied} +test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix openpipe fcopy} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts -nonewline $f1 { + fconfigure stdin -translation binary -blocking 0 + fconfigure stdout -buffering none -translation binary + fcopy stdin stdout + } + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + fconfigure $f1 -translation binary -buffering none + puts -nonewline $f1 A + after 2000 {set ::done timeout} + fileevent $f1 readable {set ::done ok} + vwait ::done + set ch [read $f1 1] + close $f1 + list $::done $ch +} {ok A} +test io-53.13 {TclCopyChannel: read error reporting} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch read} + } + finalize { + return + } + watch {} + read { + error FAIL + } + } + } + set outFile [makeFile {} out] +} -body { + set in [chan create read [namespace which driver]] + chan configure $in -translation binary + set out [open $outFile wb] + chan copy $in $out +} -cleanup { + catch {close $in} + catch {close $out} + removeFile out + rename driver {} +} -result {error reading "*": *} -returnCodes error -match glob +test io-53.14 {TclCopyChannel: write error reporting} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + return {initialize finalize watch write} + } + finalize { + return + } + watch {} + write { + error FAIL + } + } + } + set inFile [makeFile {aaa} in] +} -body { + set in [open $inFile rb] + set out [chan create write [namespace which driver]] + chan configure $out -translation binary + chan copy $in $out +} -cleanup { + catch {close $in} + catch {close $out} + removeFile in + rename driver {} +} -result {error writing "*": *} -returnCodes error -match glob +test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup { + proc driver {cmd args} { + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 +} -body { + chan copy $c $outChan +} -cleanup { + close $outChan + close $c + removeFile out +} -result 100 +test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup { + proc driver {cmd args} { + variable buffer + variable index + variable blocked + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + [string repeat a 100]] + set blocked($chan) 1 + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) blocked($chan) + return + } + watch {} + read { + if {$blocked($chan)} { + set blocked($chan) [expr {!$blocked($chan)}] + return -code error EAGAIN + } + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 -translation lf + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 -translation lf +} -body { + chan copy $c $outChan +} -cleanup { + close $outChan + close $c + removeFile out +} -result 100 +test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup { + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) [encoding convertto utf-8 \ + line\n[string repeat a 100]line\n] + return {initialize finalize watch read} + } + finalize { + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + return $result + } + } + } + set c [chan create read [namespace which driver]] + chan configure $c -encoding utf-8 -translation lf -buffersize 107 + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 -translation lf +} -body { + list [gets $c] [chan copy $c $outChan -size 100] [gets $c] +} -cleanup { + close $outChan + close $c + removeFile out +} -result {line 100 line} test io-54.1 {Recursive channel events} {socket fileevent} { # This test checks to see if file events are delivered during recursive @@ -7473,12 +8253,12 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test io-60.1 {writing illegal utf sequences} {openpipe fileevent} { +test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] puts $out { - puts [encoding convertfrom identity \xe2] + puts [testbytestring \xe2] exit 1 } proc readit {pipe} { @@ -7788,6 +8568,64 @@ test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup { close $f } -result {1 {can not find channel named "@@"}} +test io-73.3 {[5adc350683] [gets] after EOF} -setup { + set fn [makeFile {} io-73.3] + set rfd [open $fn r] + set wfd [open $fn a] + chan configure $wfd -buffering line + read $rfd +} -body { + set result [eof $rfd] + puts $wfd "more data" + lappend result [eof $rfd] + lappend result [gets $rfd] + lappend result [eof $rfd] + lappend result [gets $rfd] + lappend result [eof $rfd] +} -cleanup { + close $wfd + close $rfd + removeFile io-73.3 +} -result {1 1 {more data} 0 {} 1} + +test io-73.4 {[5adc350683] [read] after EOF} -setup { + set fn [makeFile {} io-73.4] + set rfd [open $fn r] + set wfd [open $fn a] + chan configure $wfd -buffering line + read $rfd +} -body { + set result [eof $rfd] + puts $wfd "more data" + lappend result [eof $rfd] + lappend result [read $rfd] + lappend result [eof $rfd] +} -cleanup { + close $wfd + close $rfd + removeFile io-73.4 +} -result {1 1 {more data +} 1} + +test io-73.5 {effect of eof on encoding end flags} -setup { + set fn [makeFile {} io-73.5] + set rfd [open $fn r] + set wfd [open $fn a] + chan configure $wfd -buffering none -translation binary + chan configure $rfd -buffersize 5 -encoding utf-8 + read $rfd +} -body { + set result [eof $rfd] + puts -nonewline $wfd "more\u00c2\u00a0data" + lappend result [eof $rfd] + lappend result [read $rfd] + lappend result [eof $rfd] +} -cleanup { + close $wfd + close $rfd + removeFile io-73.5 +} -result [list 1 1 more\u00a0data 1] + # ### ### ### ######### ######### ######### # cleanup diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 5eb0206..4fbc380 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -24,7 +24,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # Custom constraints used in this file testConstraint fcopy [llength [info commands fcopy]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] #---------------------------------------------------------------------- @@ -294,7 +294,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr close $srv unset cli srv port rename iocmdSRV {} -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -peername, or -sockname} +} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -connecting, -peername, or -sockname} test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] @@ -639,7 +639,7 @@ test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} { } "1 {channel \"$rfile\" wasn't opened for writing}" test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile foo bar} msg] $msg -} {1 {bad switch "foo": must be -size or -command}} +} {1 {bad option "foo": must be -size or -command}} test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile -size foo} msg] $msg } {1 {expected integer but got "foo"}} @@ -793,6 +793,90 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g rename foo {} set res } -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}} +test iocmd-21.20 {Bug 88aef05cda} -setup { + proc foo {method chan args} { + switch -- $method blocking { + chan configure $chan -blocking [lindex $args 0] + return + } initialize { + return {initialize finalize watch blocking read write + configure cget cgetall} + } finalize { + return + } + } + set ch [chan create {read write} foo] +} -body { + list [catch {chan configure $ch -blocking 0} m] $m +} -cleanup { + close $ch + rename foo {} +} -match glob -result {1 {*nested eval*}} +test iocmd-21.21 {[close] in [read] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + close $chan + return a + } + } + set ch [chan create read foo] +} -body { + read $ch 0 +} -cleanup { + close $ch + rename foo {} +} -result {} +test iocmd-21.22 {[close] in [read] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return a + } + } + set ch [chan create read foo] +} -body { + read $ch 1 +} -returnCodes error -cleanup { + catch {close $ch} + rename foo {} +} -match glob -result {*invalid argument*} +test iocmd-21.23 {[close] in [gets] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return \n + } + } + set ch [chan create read foo] +} -body { + gets $ch +} -cleanup { + catch {close $ch} + rename foo {} +} -result {} +test iocmd-21.24 {[close] in binary [gets] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return \n + } + } + set ch [chan create read foo] +} -body { + chan configure $ch -translation binary + gets $ch +} -cleanup { + catch {close $ch} + rename foo {} +} -result {} # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. @@ -1051,6 +1135,20 @@ test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glo rename foo {} unset res } -result {{read rc* 4096} {} 0} +test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + set args [lassign $args sub id] + if {$sub ne "read"} {return} + close $id + return {} + } + set c [chan create {r} foo] + note [read $c] + rename foo {} + set res +} -result {{read rc* 4096} {}} # --- === *** ########################### # method write @@ -1978,13 +2076,13 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m proc foo {args} { oninit; onfinal; track; # destroy interpreter during channel access - # Actually not possible for an interp to destroy itself. - interp delete {} - return} + suicide + } set chan [chan create {r w} foo] fconfigure $chan -buffering none set chan }] + interp alias $ida suicide {} interp delete $ida # Move channel to 2nd thread. interp eval $ida [list testchannel cut $chan] @@ -2002,8 +2100,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set res }] set res -} -constraints {testchannel impossible} \ - -result {Owner lost} +} -constraints {testchannel} -result {Owner lost} test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 @@ -2651,10 +2748,9 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ init* {set ret {initialize finalize watch read}} watch { set l [lindex $args 0] + catch {after cancel $::timer} if {[llength $l]} { set ::timer [after $::drive [list POST $ch]] - } else { - after cancel $::timer } } finalize { @@ -2717,7 +2813,9 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ update } LOG THREAD-LOOP-DONE - thread::exit + #thread::exit + # Thread exits cause leaks; Use clean thread shutdown + set forever yourGirl } LOG MAIN_WAITING @@ -2726,10 +2824,11 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ set res } -cleanup { + after cancel $::timer rename LOG {} rename POST {} rename HANDLER {} - unset beat drive data forever res tid ch + unset beat drive data forever res tid ch timer } -match glob \ -result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}} diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 7027ec1..e179eab 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -21,7 +21,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # Custom constraints used in this file testConstraint testchannel [llength [info commands testchannel]] -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # testchannel cut|splice Both needed to test the reflection in threads. # thread::send @@ -539,7 +539,46 @@ test iortrans-4.8 {chan read, read, bug 2921116} -setup { tempdone rename foo {} } -result {{read rt* {test data -}} file*} +}} {}} +test iortrans-4.8.1 {chan read, bug 721ec69271} -setup { + set res {} +} -match glob -body { + proc foo {fd args} { + handle.initialize + handle.finalize + lappend ::res $args + # Kill and recreate transform while it is operating + chan pop $fd + chan push $fd [list foo $fd] + } + set c [chan push [set c [tempchan]] [list foo $c]] + chan configure $c -buffersize 2 + lappend res [read $c] +} -cleanup { + tempdone + rename foo {} +} -result {{read rt* te} {read rt* st} {read rt* { d}} {read rt* at} {read rt* {a +}} {}} +test iortrans-4.8.2 {chan read, bug 721ec69271} -setup { + set res {} +} -match glob -body { + proc foo {fd args} { + handle.initialize + handle.finalize + lappend ::res $args + # Kill and recreate transform while it is operating + chan pop $fd + chan push $fd [list foo $fd] + return x + } + set c [chan push [set c [tempchan]] [list foo $c]] + chan configure $c -buffersize 1 + lappend res [read $c] +} -cleanup { + tempdone + rename foo {} +} -result {{read rt* t} {read rt* e} {read rt* s} {read rt* t} {read rt* { }} {read rt* d} {read rt* a} {read rt* t} {read rt* a} {read rt* { +}} {}} test iortrans-4.9 {chan read, gets, bug 2921116} -setup { set res {} } -match glob -body { @@ -557,7 +596,180 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup { tempdone rename foo {} } -result {{read rt* {test data -}} file*} +}} {}} + +# Driver for a base channel that emits several short "files" +# with each terminated by a fleeting EOF + proc driver {cmd args} { + variable ::tcl::buffer + variable ::tcl::index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ..... + return {initialize finalize watch read} + } + finalize { + if {![info exists index($chan)]} {return} + unset index($chan) buffer($chan) + array unset index + array unset buffer + return + } + watch {} + read { + set n [lindex $args 1] + if {![info exists index($chan)]} { + driver initialize $chan + } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + if {[string length $result] == 0} { + driver finalize $chan + } + return $result + } + } + } + +# Channel read transform that is just the identity - pass all through + proc idxform {cmd handle args} { + switch -- $cmd { + initialize { + return {initialize finalize read} + } + finalize { + return + } + read { + lassign $args buffer + return $buffer + } + } + } + +# Test that all EOFs pass through full xform stack. Proper data boundaries. +# Check robustness against buffer sizes. +test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.10.1 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + chan configure $chan -buffersize 3 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.10.2 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + chan configure $chan -buffersize 5 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + +rename idxform {} + +# Channel read transform that delays the data and always returns something + proc delayxform {cmd handle args} { + variable store + switch -- $cmd { + initialize { + set store($handle) {} + return {initialize finalize read drain} + } + finalize { + unset store($handle) + return + } + read { + lassign $args buffer + if {$store($handle) eq {}} { + set reply [string index $buffer 0] + set store($handle) [string range $buffer 1 end] + } else { + set reply $store($handle) + set store($handle) $buffer + } + return $reply + } + drain { + delayxform read $handle {} + } + } + } + +# Test that all EOFs pass through full xform stack. Proper data boundaries. +# Check robustness against buffer sizes. +test iortrans-4.11 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.11.1 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + chan configure $chan -buffersize 3 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.11.2 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + chan configure $chan -buffersize 5 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + + rename delayxform {} + +# Channel read transform that delays the data and may return {} + proc delay2xform {cmd handle args} { + variable store + switch -- $cmd { + initialize { + set store($handle) {} + return {initialize finalize read drain} + } + finalize { + unset store($handle) + return + } + read { + lassign $args buffer + set reply $store($handle) + set store($handle) $buffer + return $reply + } + drain { + delay2xform read $handle {} + } + } + } + +test iortrans-4.12 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delay2xform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + + rename delay2xform {} + rename driver {} + # --- === *** ########################### # method write (via puts) @@ -995,22 +1207,24 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces # Magic to get the test* commands in the slaves load {} Tcltest $ida load {} Tcltest $idb -} -constraints {testchannel impossible} -match glob -body { +} -constraints {testchannel} -match glob -body { # Set up channel in thread set chan [interp eval $ida $helperscript] + interp eval $ida [list ::variable tempchan [tempchan]] + interp transfer {} $::tempchan $ida set chan [interp eval $ida { proc foo {args} { handle.initialize clear drain flush limit? read write handle.finalize lappend ::res $args - # Destroy interpreter during channel access. Actually not - # possible for an interp to destroy itself. - interp delete {} - return} - set chan [chan push [tempchan] foo] + # Destroy interpreter during channel access. + suicide + } + set chan [chan push $tempchan foo] fconfigure $chan -buffering none set chan }] + interp alias $ida suicide {} interp delete $ida # Move channel to 2nd thread, transform goes with it. interp eval $ida [list testchannel cut $chan] interp eval $idb [list testchannel splice $chan] diff --git a/tests/iogt.test b/tests/iogt.test index d4c31d2..1ed89f7 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -220,6 +220,36 @@ proc id_fulltrail {var op data} { return $res } +proc id_torture {chan op data} { + switch -- $op { + create/write - + create/read - + delete/write - + delete/read - + clear_read {;#ignore} + flush/write - + flush/read {} + write { + global level + if {$level} { + return + } + incr level + testchannel unstack $chan + testchannel transform $chan \ + -command [namespace code [list id_torture $chan]] + return $data + } + read { + testchannel unstack $chan + testchannel transform $chan \ + -command [namespace code [list id_torture $chan]] + return $data + } + query/maxRead {return -1} + } +} + proc counter {var op data} { namespace upvar [namespace current] $var n @@ -280,7 +310,7 @@ proc counter_audit {var vtrail op data} { } proc rblocks {var vtrail n op data} { - namespace upvar [namespace current] $var n $vtrail trail + namespace upvar [namespace current] $var buf $vtrail trail set res {} @@ -326,6 +356,11 @@ proc audit_ops {var -attach channel} { proc audit_flow {var -attach channel} { testchannel transform $channel -command [namespace code [list id_fulltrail $var]] } + +proc torture {-attach channel} { + testchannel transform $channel -command [namespace code [list id_torture $channel]] +} + proc stopafter {var n -attach channel} { namespace upvar [namespace current] $var vn set vn $n @@ -445,6 +480,7 @@ query/maxRead read query/maxRead flush/read +query/maxRead delete/read -------- create/write @@ -491,6 +527,7 @@ read { } query/maxRead {} -1 flush/read {} {} +query/maxRead {} -1 delete/read {} *ignored* -------- create/write {} *ignored* @@ -542,15 +579,35 @@ write %^&*()_+-= %^&*()_+-= write { } { } +query/maxRead {} -1 delete/read {} *ignored* flush/write {} {} delete/write {} *ignored*} +test iogt-2.4 {basic I/O, mixed trail} {testchannel} { + set fh [open $path(dummy) r] + torture -attach $fh + chan configure $fh -buffersize 2 + set x [read $fh] + testchannel unstack $fh + close $fh + set x +} {} +test iogt-2.5 {basic I/O, mixed trail} {testchannel} { + set ::level 0 + set fh [open $path(dummyout) w] + torture -attach $fh + puts -nonewline $fh abcdef + flush $fh + testchannel unstack $fh + close $fh +} {} + test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { proc DoneCopy {n {err {}}} { variable copy 1 } -} -constraints {testchannel hangs} -body { +} -constraints {testchannel knownBug} -body { # This test to check the validity of aquired Tcl_Channel references is not # possible because even a backgrounded fcopy will immediately start to # copy data, without waiting for the event loop. This is done only in case @@ -561,6 +618,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { # delay, causing the fcopy to underflow immediately. set fin [open $path(dummy) r] fevent 1000 500 {20 20 20 10 1 1} { + variable copy close $fin set fout [open dummyout w] flush $sock; # now, or fcopy will error us out @@ -594,23 +652,30 @@ test iogt-4.0 {fileevent readable, after transform} -setup { proc Done {args} { variable stop 1 } -} -constraints {testchannel hangs} -body { + proc Get {sock} { + variable trail + variable got + if {[eof $sock]} { + Done + lappend trail "xxxxxxxxxxxxx" + close $sock + return + } + lappend trail "vvvvvvvvvvvvv" + lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" + lappend trail "=============" + #puts stdout $__ ; flush stdout + #read $sock + } + +} -constraints {testchannel knownBug} -body { fevent 1000 500 {20 20 20 10 1} { + variable stop audit_flow trail -attach $sock rblocks_t rbuf trail 23 -attach $sock - fileevent $sock readable [namespace code { - if {[eof $sock]} { - Done - lappend trail "xxxxxxxxxxxxx" - close $sock - } else { - lappend trail "vvvvvvvvvvvvv" - lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" - lappend trail "=============" - #puts stdout $__; flush stdout - #read $sock - } - }] + + fileevent $sock readable [namespace code [list Get $sock]] + flush $sock; # Now, or fcopy will error us out # But the 1 second delay should be enough to initialize everything # else here. @@ -619,6 +684,7 @@ test iogt-4.0 {fileevent readable, after transform} -setup { join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n } -cleanup { rename Done {} + rename Get {} } -result {[[]] [[abcdefghijklmnopqrstuvw]] [[xyz0123456789,./?><;'\|]] @@ -706,7 +772,7 @@ test iogt-5.0 {EOF simulation} -setup { set fin [open $path(dummy) r] set fout [open $path(dummyout) w] set trail [list] -} -constraints {testchannel unknownFailure} -result { +} -constraints {testchannel knownBug} -result { audit_flow trail -attach $fin stopafter_audit d trail 20 -attach $fin audit_flow trail -attach $fout @@ -785,6 +851,15 @@ test iogt-6.0 {Push back} -constraints testchannel -body { close $f } -result {xxx} test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { + + # This test demonstrates the bug/misfeature in the stacked + # channel implementation that data can be discarded if it is + # read into the buffers of one channel in the stack, and then + # that channel is popped before anything above it reads. + # + # This bug can be worked around by always setting -buffersize + # to 1, but who wants to do that? + set f [open $path(dummy) r] # contents of dummy = "abcdefghi..." read $f 3; # skip behind "abc" @@ -796,6 +871,80 @@ test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { close $f } -result {xxxghi} + +# Driver for a base channel that emits several short "files" +# with each terminated by a fleeting EOF + proc driver {cmd args} { + variable buffer + variable index + set chan [lindex $args 0] + switch -- $cmd { + initialize { + set index($chan) 0 + set buffer($chan) ..... + return {initialize finalize watch read} + } + finalize { + if {![info exists index($chan)]} {return} + unset index($chan) buffer($chan) + return + } + watch {} + read { + set n [lindex $args 1] + if {![info exists index($chan)]} { + driver initialize $chan + } + set new [expr {$index($chan) + $n}] + set result [string range $buffer($chan) $index($chan) $new-1] + set index($chan) $new + if {[string length $result] == 0} { + driver finalize $chan + } + return $result + } + } + } + +test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body { + set chan [chan create read [namespace which driver]] + identity -attach $chan + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + +proc delay {op data} { + variable store + switch -- $op { + create/write - create/read - + delete/write - delete/read - + flush/write - write - + clear_read {;#ignore} + flush/read - + read { + if {![info exists store]} {set store {}} + set reply $store + set store $data + return $reply + } + query/maxRead {return -1} + } +} + +test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body { + set chan [chan create read [namespace which driver]] + testchannel transform $chan -command [namespace code delay] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} + +rename delay {} +rename driver {} + # cleanup foreach file [list dummy dummyout __echo_srv__.tcl] { removeFile $file diff --git a/tests/listObj.test b/tests/listObj.test index 8b24aa9..d7fb46c 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -196,6 +196,10 @@ test listobj-10.1 {Bug [2971669]} {*}{ -result {{a b c d e} {} {a b c d e f}} } +test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj { + testobj bug3598580 +} 123 + # cleanup ::tcltest::cleanupTests return diff --git a/tests/lmap.test b/tests/lmap.test new file mode 100644 index 0000000..08035d9 --- /dev/null +++ b/tests/lmap.test @@ -0,0 +1,471 @@ +# Commands covered: lmap, continue, break +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 2011 Trevor Davel +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: $ + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +unset -nocomplain a b i x + +# ----- Non-compiled operation ----------------------------------------------- + +# Basic "lmap" operation (non-compiled) +test lmap-1.1 {basic lmap tests} { + set a {} + lmap i {a b c d} { + set a [concat $a $i] + } +} {a {a b} {a b c} {a b c d}} +test lmap-1.2 {basic lmap tests} { + lmap i {a b {{c d} e} {123 {{x}}}} { + set i + } +} {a b {{c d} e} {123 {{x}}}} +test lmap-1.2a {basic lmap tests} { + lmap i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } +} {a b {{c d} e} {123 {{x}}}} +test lmap-1.4 {basic lmap tests} -returnCodes error -body { + lmap +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.6 {basic lmap tests} -returnCodes error -body { + lmap i +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.8 {basic lmap tests} -returnCodes error -body { + lmap i j +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.10 {basic lmap tests} -returnCodes error -body { + lmap i j k l +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.11 {basic lmap tests} { + lmap i {} { + set i + } +} {} +test lmap-1.12 {basic lmap tests} { + lmap i {} { + return -level 0 x + } +} {} +test lmap-1.13 {lmap errors} -returnCodes error -body { + lmap {{a}{b}} {1 2 3} {} +} -result {list element in braces followed by "{b}" instead of space} +test lmap-1.14 {lmap errors} -returnCodes error -body { + lmap a {{1 2}3} {} +} -result {list element in braces followed by "3" instead of space} +unset -nocomplain a +test lmap-1.15 {lmap errors} -setup { + unset -nocomplain a +} -body { + set a(0) 44 + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo +} -result {1 {can't set "a": variable is array} {can't set "a": variable is array + (setting lmap loop variable "a") + invoked from within +"lmap a {1 2 3} {}"}} +test lmap-1.16 {lmap errors} -returnCodes error -body { + lmap {} {} {} +} -result {lmap varlist is empty} +unset -nocomplain a + +# Parallel "lmap" operation (non-compiled) +test lmap-2.1 {parallel lmap tests} { + lmap {a b} {1 2 3 4} { + list $b $a + } +} {{2 1} {4 3}} +test lmap-2.2 {parallel lmap tests} { + lmap {a b} {1 2 3 4 5} { + list $b $a + } +} {{2 1} {4 3} {{} 5}} +test lmap-2.3 {parallel lmap tests} { + lmap a {1 2 3} b {4 5 6} { + list $b $a + } +} {{4 1} {5 2} {6 3}} +test lmap-2.4 {parallel lmap tests} { + lmap a {1 2 3} b {4 5 6 7 8} { + list $b $a + } +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test lmap-2.5 {parallel lmap tests} { + lmap {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test lmap-2.6 {parallel lmap tests} { + lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } +} {11111 22222 33333} +test lmap-2.7 {parallel lmap tests} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } +} {{1111 2} 222 33 4} +test lmap-2.8 {parallel lmap tests} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test lmap-2.9 {lmap only sets vars if repeating loop} { + namespace eval ::lmap_test { + set rgb {65535 0 0} + lmap {r g b} [set rgb] {} + set ::x "r=$r, g=$g, b=$b" + } + namespace delete ::lmap_test + set x +} {r=65535, g=0, b=0} +test lmap-2.10 {lmap only supports local scalar variables} -setup { + unset -nocomplain a +} -body { + lmap {a(3)} {1 2 3 4} {set {a(3)}} +} -result {1 2 3 4} +unset -nocomplain a + +# "lmap" with "continue" and "break" (non-compiled) +test lmap-3.1 {continue tests} { + lmap i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } +} {a c d} +test lmap-3.2 {continue tests} { + set x 0 + list [lmap i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x +} {b 4} +test lmap-3.3 {break tests} { + set x 0 + list [lmap i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x +} {{a b} 3} +# Check for bug similar to #406709 +test lmap-3.4 {break tests} { + set a 1 + lmap b b {list [concat a; break]; incr a} + incr a +} {2} + +# ----- Compiled operation --------------------------------------------------- + +# Basic "lmap" operation (compiled) +test lmap-4.1 {basic lmap tests} { + apply {{} { + set a {} + lmap i {a b c d} { + set a [concat $a $i] + } + }} +} {a {a b} {a b c} {a b c d}} +test lmap-4.2 {basic lmap tests} { + apply {{} { + lmap i {a b {{c d} e} {123 {{x}}}} { + set i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test lmap-4.2a {basic lmap tests} { + apply {{} { + lmap i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test lmap-4.4 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.6 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap i }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.8 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap i j }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.10 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap i j k l }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.11 {basic lmap tests} { + apply {{} { lmap i {} { set i } }} +} {} +test lmap-4.12 {basic lmap tests} { + apply {{} { lmap i {} { return -level 0 x } }} +} {} +test lmap-4.13 {lmap errors} -returnCodes error -body { + apply {{} { lmap {{a}{b}} {1 2 3} {} }} +} -result {list element in braces followed by "{b}" instead of space} +test lmap-4.14 {lmap errors} -returnCodes error -body { + apply {{} { lmap a {{1 2}3} {} }} +} -result {list element in braces followed by "3" instead of space} +unset -nocomplain a +test lmap-4.15 {lmap errors} { + apply {{} { + set a(0) 44 + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo + }} +} {1 {can't set "a": variable is array} {can't set "a": variable is array + while executing +"lmap a {1 2 3} {}"}} +test lmap-4.16 {lmap errors} -returnCodes error -body { + apply {{} { + lmap {} {} {} + }} +} -result {lmap varlist is empty} +unset -nocomplain a + +# Parallel "lmap" operation (compiled) +test lmap-5.1 {parallel lmap tests} { + apply {{} { + lmap {a b} {1 2 3 4} { + list $b $a + } + }} +} {{2 1} {4 3}} +test lmap-5.2 {parallel lmap tests} { + apply {{} { + lmap {a b} {1 2 3 4 5} { + list $b $a + } + }} +} {{2 1} {4 3} {{} 5}} +test lmap-5.3 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {4 5 6} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3}} +test lmap-5.4 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {4 5 6 7 8} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test lmap-5.5 {parallel lmap tests} { + apply {{} { + lmap {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } + }} +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test lmap-5.6 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } + }} +} {11111 22222 33333} +test lmap-5.7 {parallel lmap tests} { + apply {{} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } + }} +} {{1111 2} 222 33 4} +test lmap-5.8 {parallel lmap tests} { + apply {{} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } + }} +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test lmap-5.9 {lmap only sets vars if repeating loop} { + apply {{} { + set rgb {65535 0 0} + lmap {r g b} [set rgb] {} + return "r=$r, g=$g, b=$b" + }} +} {r=65535, g=0, b=0} +test lmap-5.10 {lmap only supports local scalar variables} { + apply {{} { + lmap {a(3)} {1 2 3 4} {set {a(3)}} + }} +} {1 2 3 4} + +# "lmap" with "continue" and "break" (compiled) +test lmap-6.1 {continue tests} { + apply {{} { + lmap i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } + }} +} {a c d} +test lmap-6.2 {continue tests} { + apply {{} { + list [lmap i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x + }} +} {b 4} +test lmap-6.3 {break tests} { + apply {{} { + list [lmap i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x + }} +} {{a b} 3} +# Check for bug similar to #406709 +test lmap-6.4 {break tests} { + apply {{} { + set a 1 + lmap b b {list [concat a; break]; incr a} + incr a + }} +} {2} + +# ----- Special cases and bugs ----------------------------------------------- +test lmap-7.1 {compiled lmap backward jump works correctly} -setup { + unset -nocomplain x +} -body { + array set x {0 zero 1 one 2 two 3 three} + lsort [apply {{arrayName} { + upvar 1 $arrayName a + lmap member [array names a] { + list $member [set a($member)] + } + }} x] +} -result [lsort {{0 zero} {1 one} {2 two} {3 three}}] +test lmap-7.2 {noncompiled lmap and shared variable or value list objects that are converted to another type} -setup { + unset -nocomplain x +} -body { + lmap {12.0} {a b c} { + set x 12.0 + set x [expr $x + 1] + } +} -result {13.0 13.0 13.0} +# Test for incorrect "double evaluation" semantics +test lmap-7.3 {delayed substitution of body} { + apply {{} { + set a 0 + lmap a [list 1 2 3] " + set x $a + " + return $x + }} +} {0} +# Related to "foreach" test for [Bug 1189274]; crash on failure +test lmap-7.4 {empty list handling} { + proc crash {} { + rename crash {} + set a "x y z" + set b "" + lmap aa $a bb $b { set x "aa = $aa bb = $bb" } + } + crash +} {{aa = x bb = } {aa = y bb = } {aa = z bb = }} +# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled +# version. +test lmap-7.5 {compiled empty var list} -returnCodes error -body { + proc foo {} { + lmap {} x { + error "reached body" + } + } + foo +} -cleanup { + catch {rename foo ""} +} -result {lmap varlist is empty} +test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup { + proc demo {} { + set vals {1 2 3 4} + trace add variable x write {string length $vals ;# } + lmap {x y} $vals {format $y} + } +} -body { + demo +} -cleanup { + rename demo {} +} -result {2 4} +# Huge lists must not overflow the bytecode interpreter (development bug) +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] +} -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] +} -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 +} 0 +test lmap-7.9a {error then dereference loop var (dev bug)} { + catch { lmap a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 + +# ----- Coroutines ----------------------------------------------------------- +test lmap-8.1 {lmap non-compiled with coroutines} -body { + coroutine coro apply {{} { + set values [yield [info coroutine]] + eval lmap i [list $values] {{ yield $i }} + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} -cleanup { + catch {rename coro ""} +} -result {{1 2 3 4 5 6} {}} +test lmap-8.2 {lmap compiled with coroutines} -body { + coroutine coro apply {{} { + set values [yield [info coroutine]] + lmap i $values { yield $i } + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} -cleanup { + catch {rename coro ""} +} -result {{1 2 3 4 5 6} {}} + +# cleanup +unset -nocomplain a x +catch {rename foo {}} +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/load.test b/tests/load.test index 78bf64c..9536271 100644 --- a/tests/load.test +++ b/tests/load.test @@ -47,32 +47,38 @@ testConstraint testsimplefilesystem \ test load-1.1 {basic errors} {} { list [catch {load} msg] $msg -} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}" +} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}" test load-1.2 {basic errors} {} { list [catch {load a b c d} msg] $msg -} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}" +} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?\"}" test load-1.3 {basic errors} {} { list [catch {load a b foobar} msg] $msg } {1 {could not find interpreter "foobar"}} test load-1.4 {basic errors} {} { - list [catch {load {}} msg] $msg + list [catch {load -global {}} msg] $msg } {1 {must specify either file name or package name}} test load-1.5 {basic errors} {} { - list [catch {load {} {}} msg] $msg + list [catch {load -lazy {} {}} msg] $msg } {1 {must specify either file name or package name}} test load-1.6 {basic errors} {} { list [catch {load {} Unknown} msg] $msg } {1 {package "Unknown" isn't loaded statically}} +test load-1.7 {basic errors} {} { + list [catch {load -abc foo} msg] $msg +} "1 {bad option \"-abc\": must be -global, -lazy, or --}" +test load-1.8 {basic errors} {} { + list [catch {load -global} msg] $msg +} "1 {couldn't figure out package name for -global}" test load-2.1 {basic loading, with guess for package name} \ [list $dll $loaded] { - load [file join $testDir pkga$ext] + load -global [file join $testDir pkga$ext] list [pkga_eq abc def] [lsort [info commands pkga_*]] } {0 {pkga_eq pkga_quote}} interp create -safe child test load-2.2 {loading into a safe interpreter, with package name conversion} \ [list $dll $loaded] { - load [file join $testDir pkgb$ext] pKgB child + load -lazy [file join $testDir pkgb$ext] pKgB child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} @@ -126,7 +132,7 @@ test load-5.1 {file name not specified and no static package: pick default} \ [list $dll $loaded] { catch {interp delete x} interp create x - load [file join $testDir pkga$ext] pkga + load -global [file join $testDir pkga$ext] pkga load {} pkga x set result [info loaded x] interp delete x @@ -182,7 +188,7 @@ test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] { load [file join $testDir pkgb$ext] pkgb list [info loaded {}] [lsort [info commands pkgb_*]] -} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_sub pkgb_unsafe}] +} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \ @@ -209,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/lrange.test b/tests/lrange.test index 6c81872..17a757e 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -15,7 +15,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } - + test lrange-1.1 {range of list elements} { lrange {a b c d} 1 2 } {b c} @@ -61,9 +61,11 @@ test lrange-1.14 {range of list elements} { test lrange-1.15 {range of list elements} { concat \"[lrange {a b \{\ } 0 2]" } {"a b \{\ "} +# emacs highlighting bug workaround --> " test lrange-1.16 {list element quoting} { lrange {[append a .b]} 0 end } {{[append} a .b\]} + test lrange-2.1 {error conditions} { list [catch {lrange a b} msg] $msg } {1 {wrong # args: should be "lrange list first last"}} @@ -83,6 +85,16 @@ test lrange-2.6 {error conditions} { list [catch {lrange "a b c \{ d e" 1 4} msg] $msg } {1 {unmatched open brace in list}} +test lrange-3.1 {Bug 3588366: end-offsets before start} { + apply {l { + lrange $l 0 end-5 + }} {1 2 3 4 5} +} {} + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/lreplace.test b/tests/lreplace.test index 5f675bc..d1319c6 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -15,7 +15,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } - + test lreplace-1.1 {lreplace command} { lreplace {1 2 3 4 5} 0 0 a } {a 2 3 4 5} @@ -130,7 +130,28 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} { p } "a b c" +test lreplace-4.1 {Bug ccc2c2cc98: lreplace edge case} { + lreplace {} 1 1 +} {} +# Note that this test will fail in 8.5 +test lreplace-4.2 {Bug ccc2c2cc98: lreplace edge case} { + lreplace { } 1 1 +} {} +test lreplace-4.3 {lreplace edge case} { + lreplace {1 2 3} 2 0 +} {1 2 3} +test lreplace-4.4 {lreplace edge case} { + lreplace {1 2 3 4 5} 3 1 +} {1 2 3 4 5} +test lreplace-4.5 {lreplace edge case} { + lreplace {1 2 3 4 5} 3 0 _ +} {1 2 3 _ 4 5} + # cleanup catch {unset foo} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: 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..cded1f4 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -303,7 +303,7 @@ test namespace-9.4 {Tcl_Import, simple import} { } test_ns_import::p } {cmd1: 123} -test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} { +test namespace-9.5 {Tcl_Import, RFE 1230597} { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg } {0 {}} test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { @@ -558,6 +558,15 @@ test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { lappend l [info commands ::test_ns_import::*] } } {::test_ns_import::cmd1 {}} +test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { + # Will panic if still buggy + namespace eval src {namespace export foo; proc foo {} {}} + namespace eval dst {namespace import [namespace parent]::src::foo} + trace add command src::foo delete \ + "[list namespace delete [namespace current]::dst] ;#" + proc src::foo {} {} + namespace delete src +} {} test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1111,6 +1120,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_*]} @@ -2932,6 +2949,10 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ rename getbytes {} unset i ns start end } -result 0 + +test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} { + info class [format %s constructor] oo::object +} "" # cleanup catch {rename cmd1 {}} diff --git a/tests/nre.test b/tests/nre.test index b8ef2e0..e512eac 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -74,7 +74,6 @@ test nre-1.1 {self-recursive procs} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-1.2 {self-recursive lambdas} -setup { set a [list i [makebody {apply $::a $i}]] } -body { @@ -85,7 +84,6 @@ test nre-1.2 {self-recursive lambdas} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-1.3 {mutually recursive procs and lambdas} -setup { proc a i { apply $::b [incr i] @@ -153,6 +151,27 @@ test nre-4.1 {ensembles are not recursive} -setup { testnrelevels } -result {{0 2 1 1} 0} +test nre-4.2 {(compiled) ensembles do not break tailcall} -setup { + # Fix Bug d87cb18205 + proc b {} { + tailcall append result first + } + set map [namespace ensemble configure ::dict -map] + dict set map a b + namespace ensemble configure ::dict -map $map + proc demo {} { + dict a + append result second + } +} -body { + demo +} -cleanup { + rename demo {} + namespace ensemble configure ::dict -map [dict remove $map a] + unset map + rename b {} +} -result firstsecond + test nre-5.1 {[namespace eval] is not recursive} -setup { namespace eval ::foo { setabs @@ -164,8 +183,7 @@ test nre-5.1 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 3 2 2} 0} - +} -result {{0 2 2 2} 0} test nre-5.2 {[namespace eval] is not recursive} -setup { namespace eval ::foo { setabs @@ -177,7 +195,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 3 2 2} 0} +} -result {{0 2 2 2} 0} test nre-6.1 {[uplevel] is not recursive} -setup { proc a i [makebody {uplevel 1 [list a $i]}] @@ -189,7 +207,6 @@ test nre-6.1 {[uplevel] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-6.2 {[uplevel] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "set x $i; a $i"}] @@ -211,7 +228,6 @@ test nre-7.1 {[catch] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 3 3 0} 0} - test nre-7.2 {[if] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "if 1 {a $i}"}] @@ -222,7 +238,6 @@ test nre-7.2 {[if] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.3 {[while] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}] @@ -233,7 +248,6 @@ test nre-7.3 {[while] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.4 {[for] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}] @@ -244,7 +258,6 @@ test nre-7.4 {[for] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.5 {[foreach] is not recursive} -setup { # # Enable once [foreach] is NR-enabled @@ -258,7 +271,6 @@ test nre-7.5 {[foreach] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 3 3 0} 0} - test nre-7.6 {[eval] is not recursive} -setup { proc a i [makebody {eval [list a $i]}] } -body { @@ -269,7 +281,6 @@ test nre-7.6 {[eval] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 1} 0} - test nre-7.7 {[eval] is not recursive} -setup { proc a i [makebody {eval "a $i"}] } -body { @@ -280,7 +291,6 @@ test nre-7.7 {[eval] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 1} 0} - test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { proc foo args {} foo @@ -295,18 +305,15 @@ test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { } -body { # if switching to plain eval is not nre aware, this will cause a "cannot # yield" error - list [bar] [bar] [bar] } -cleanup { rename bar {} rename foo {} } -result {1 2 3} - test nre-8.1 {nre and {*}} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the TEBCdataPtr. This crashes on failure. - proc inner {} { set long [lrepeat 1000000 1] list {*}$long @@ -321,21 +328,18 @@ test nre-8.2 {nre and {*}, [Bug 2415422]} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the bcFramePtr. This causes an NRE assertion to fail if it is not # done properly. - proc nop {} {} proc crash {} { foreach val [list {*}[lrepeat 100000 x]] { nop } } - crash } -cleanup { rename nop {} rename crash {} } - # # Basic TclOO tests # @@ -351,7 +355,6 @@ test nre-oo.1 {really deep calls in oo - direct} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.2 {really deep calls in oo - call via [self]} -setup { oo::object create foo oo::objdefine foo method bar i [makebody {[self] bar $i}] @@ -363,7 +366,6 @@ test nre-oo.2 {really deep calls in oo - call via [self]} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.3 {really deep calls in oo - private calls} -setup { oo::object create foo oo::objdefine foo method bar i [makebody {my bar $i}] @@ -375,7 +377,6 @@ test nre-oo.3 {really deep calls in oo - private calls} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.4 {really deep calls in oo - overriding} -setup { oo::class create foo { method bar i [makebody {my bar $i}] @@ -392,7 +393,6 @@ test nre-oo.4 {really deep calls in oo - overriding} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.5 {really deep calls in oo - forwards} -setup { oo::object create foo set body [makebody {my boo $i}] @@ -409,7 +409,6 @@ test nre-oo.5 {really deep calls in oo - forwards} -setup { testnrelevels } -result {{0 2 1 1} 0} - # # NASTY BUG found by tcllib's interp package # diff --git a/tests/obj.test b/tests/obj.test index 71a39b4..151abfb 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -605,7 +605,7 @@ test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x 0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 4294967295} -test obj-33.3 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.3 {integer overflow on input} { set x 0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {0 4294967296} @@ -621,7 +621,7 @@ test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} { set x -0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 -4294967295} -test obj-33.7 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.7 {integer overflow on input} { set x -0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {0 -4294967296} diff --git a/tests/oo.test b/tests/oo.test index 540cdf3..f35b70a 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 -exact TclOO 0.7 ;# Must match value in generic/tclOO.h +package require TclOO 1.0.3 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 {} @@ -258,6 +258,29 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup { rename test-oo-1.18 {} A destroy } -result ::C +test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup { + proc test-oo-1.18 {} return +} -constraints memory -body { + leaktest { + oo::class create A + oo::class create B {superclass A} + oo::define B constructor {} {A create test-oo-1.18} + B create C + A destroy + } +} -cleanup { + rename test-oo-1.18 {} +} -result 0 +test oo-1.18.2 {Bug 21c144f0f5} -setup { + interp create slave +} -body { + slave eval { + oo::define [oo::class create foo] superclass oo::class + oo::class destroy + } +} -cleanup { + interp delete slave +} test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o namespace delete [info object namespace o] @@ -270,6 +293,23 @@ test oo-1.20 {basic test of OO functionality: my teardown post rename} -body { obj destroy info commands ::AGlobalName } -result {} +test oo-1.21 {basic test of OO functionality: default relations} -setup { + set fresh [interp create] +} -body { + lmap x [$fresh eval { + foreach cmd {instances subclasses mixins superclass} { + foreach initial {object class Slot} { + lappend x [info class $cmd ::oo::$initial] + } + } + foreach initial {object class Slot} { + lappend x [info object class ::oo::$initial] + } + return $x + }] {lsort $x} +} -cleanup { + interp delete $fresh +} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as @@ -376,6 +416,31 @@ test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup { } -returnCodes error -cleanup { namespace delete k } -result {wrong # args: should be "k next j"} +test oo-2.9 {construction failures and self creation} -setup { + set ::result {} + oo::class create Root +} -body { + oo::class create A { + superclass Root + constructor {} { + lappend ::result "in A" + error "failure in A" + } + destructor {lappend ::result [self]} + } + oo::class create B { + superclass Root + constructor {} { + lappend ::result "in B [self]" + error "failure in B" + } + destructor {lappend ::result [self]} + } + lappend ::result [catch {A create a} msg] $msg + lappend ::result [catch {B create b} msg] $msg +} -cleanup { + Root destroy +} -result {{in A} ::a 1 {failure in A} {in B ::b} ::b 1 {failure in B}} test oo-3.1 {basic test of OO functionality: destructor} -setup { # This is a bit complex because it needs to run in a sub-interp as we're @@ -936,6 +1001,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 @@ -1441,6 +1569,34 @@ test oo-12.7 {OO: filters} -setup { } -cleanup { Aclass destroy } -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}} +test oo-12.8 {OO: filters and destructors} -setup { + oo::class create Aclass + Aclass create Aobject + set ::log {} +} -body { + oo::define Aclass { + constructor {} { + lappend ::log "in constructor" + } + destructor { + lappend ::log "in destructor" + } + method bar {} { + lappend ::log "in method" + } + method Boo args { + lappend ::log [self target] + next {*}$args + } + filter Boo + } + set obj [Aclass new] + $obj bar + $obj destroy + return $::log +} -cleanup { + Aclass destroy +} -result {{in constructor} {::Aclass bar} {in method} {::oo::object destroy} {in destructor}} test oo-13.1 {OO: changing an object's class} { oo::class create Aclass @@ -1776,6 +1932,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 +2390,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 +3560,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 e78e0d0..6a48d28 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 -exact TclOO 0.7 ;# Must match value in configure.in +package require TclOO 1.0.3 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* @@ -526,6 +526,93 @@ test oo-call-1.19 {object call introspection - memory leaks} -setup { } -cleanup { leaktester destroy } -constraints memory -result 0 +test oo-call-1.20 {object call introspection - complex case} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + oo::class create ::C { + superclass root + method x {} {} + mixin B + } + oo::class create ::D { + superclass C + method x {} {} + } + oo::class create ::E { + superclass root + method x {} {} + } + oo::class create ::F { + superclass E + method x {} {} + } + oo::class create ::G { + superclass root + method x {} {} + } + oo::class create ::H { + superclass G + method x {} {} + } + oo::define F mixin H + F create y + oo::objdefine y { + method x {} {} + mixin D + } + info object call y x +} -cleanup { + root destroy +} -result {{method x ::D method} {method x ::B method} {method x ::A method} {method x ::C method} {method x ::H method} {method x ::G method} {method x object method} {method x ::F method} {method x ::E method}} +test oo-call-1.21 {object call introspection - complex case} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method y {} {} + } + oo::class create ::C { + superclass root + method x {} {} + mixin B + } + oo::class create ::D { + superclass C + filter x + } + oo::class create ::E { + superclass root + method y {} {} + method x {} {} + } + oo::class create ::F { + superclass E + method z {} {} + method q {} {} + } + F create y + oo::objdefine y { + method unknown {} {} + mixin D + filter q + } + info object call y z +} -cleanup { + root destroy +} -result {{filter x ::C method} {filter x ::E method} {filter y ::B method} {filter y ::A method} {filter y ::E method} {filter q ::F method} {method z ::F method}} test oo-call-2.1 {class call introspection} -setup { oo::class create root @@ -779,6 +866,196 @@ test oo-call-3.4 {current call introspection: in destructors} -setup { } -cleanup { root destroy } -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}} + +# Contributed tests from aspect, related to [0f42ff7871] +# +# dkf's "Principles Leading to a Fix" +# +# A method ought to work "the same" whether or not it has been overridden by +# a subclass. A tailcalled command ought to have as parent stack the same +# thing you'd get with uplevel 1. A subclass will often expect the +# superclass's result to be the result that would be returned if the +# subclass was not there. + +# Common setup: +# any invocation of bar should emit "abc\nhi\n" then return to its +# caller +set testopts { + -setup { + oo::class create Master + oo::class create Foo { + superclass Master + method bar {} { + puts abc + tailcall puts hi + puts xyz + } + } + oo::class create Foo2 { + superclass Master + } + } + -cleanup { + Master destroy + } +} + +# these succeed, showing that without [next] the bug doesn't fire +test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body { + [Foo create foo] bar +} -output [join {abc hi} \n]\n +test next-tailcall-simple-2 "my bar" {*}$testopts -body { + oo::define Foo method baz {} { + puts a + my bar + puts b + } + [Foo create foo] baz +} -output [join {a abc hi b} \n]\n +test next-tailcall-simple-3 "\[self\] bar" {*}$testopts -body { + oo::define Foo method baz {} { + puts a + [self] bar + puts b + } + [Foo create foo] baz +} -output [join {a abc hi b} \n]\n +test next-tailcall-simple-4 "foo bar" {*}$testopts -body { + oo::define Foo method baz {} { + puts a + foo bar + puts b + } + [Foo create foo] baz +} -output [join {a abc hi b} \n]\n + +# everything from here on uses [next], and fails on 8.6.4 with compilation +test next-tailcall-superclass-1 "next superclass" {*}$testopts -body { + oo::define Foo2 { + superclass Foo + method bar {} { + puts a + next + puts b + } + } + [Foo2 create foo] bar +} -output [join {a abc hi b} \n]\n +test next-tailcall-superclass-2 "nextto superclass" {*}$testopts -body { + oo::define Foo2 { + superclass Foo + method bar {} { + puts a + nextto Foo + puts b + } + } + [Foo2 create foo] bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-mixin-1 "class mixin" {*}$testopts -body { + oo::define Foo2 { + method Bar {} { + puts a + next + puts b + } + filter Bar + } + oo::define Foo mixin Foo2 + Foo create foo + foo bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body { + oo::define Foo2 { + method Bar {} { + puts a + next + puts b + } + filter Bar + } + Foo create foo + oo::objdefine foo mixin Foo2 + foo bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-filter-1 "filter method" {*}$testopts -body { + oo::define Foo method Filter {} { + puts a + next + puts b + } + oo::define Foo filter Filter + [Foo new] bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-forward-1 "forward method" {*}$testopts -body { + proc foobar {} { + puts "abc" + tailcall puts "hi" + puts "xyz" + } + oo::define Foo forward foobar foobar + oo::define Foo2 { + superclass Foo + method foobar {} { + puts a + next + puts b + } + } + [Foo2 new] foobar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-constructor-1 "next in constructor" -body { + oo::class create Foo { + constructor {} { + puts abc + tailcall puts hi + puts xyz + } + } + oo::class create Foo2 { + superclass Foo + constructor {} { + puts a + next + puts b + } + } + list [Foo new] [Foo2 new] + return "" +} -cleanup { + Foo destroy +} -output [join {abc hi a abc hi b} \n]\n + +test next-tailcall-destructor-1 "next in destructor" -body { + oo::class create Foo { + destructor { + puts abc + tailcall puts hi + puts xyz + } + } + oo::class create Foo2 { + superclass Foo + destructor { + puts a + next + puts b + } + } + Foo create foo + Foo2 create foo2 + foo destroy + foo2 destroy +} -output [join {abc hi a abc hi b} \n]\n -cleanup { + Foo destroy +} + +unset testopts cleanupTests return diff --git a/tests/parse.test b/tests/parse.test index 0f76d64..d73c725 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -20,15 +20,18 @@ namespace eval ::tcl::test::parse { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testparser [llength [info commands testparser]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testevalobjv [llength [info commands testevalobjv]] testConstraint testevalex [llength [info commands testevalex]] 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 +test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {testparser testbytestring} { + testparser [testbytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser { testparser "foo bar" -1 @@ -299,9 +302,11 @@ test parse-6.15 {ParseTokens procedure, backslash-newline} testparser { test parse-6.16 {ParseTokens procedure, backslash substitution} testparser { testparser {\n\a\x7f} 0 } {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}} -test parse-6.17 {ParseTokens procedure, null characters} testparser { - testparser [bytestring "foo\0zz"] 0 -} "- [bytestring foo\0zz] 1 word [bytestring foo\0zz] 3 text foo 0 text [bytestring \0] 0 text zz 0 {}" +test parse-6.17 {ParseTokens procedure, null characters} {testparser testbytestring} { + expr {[testparser [testbytestring "foo\0zz"] 0] eq +"- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}" + } +} 1 test parse-6.18 {ParseTokens procedure, seek past numBytes for close-bracket} testparser { # Test for Bug 681841 list [catch {testparser {[a]} 2} msg] $msg @@ -438,7 +443,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 +484,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 +492,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 +546,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 +569,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 { @@ -658,6 +663,9 @@ test parse-12.24 {Tcl_ParseVarName procedure, missing close paren in array refer test parse-12.25 {Tcl_ParseVarName procedure, nested array reference} testparser { testparser {$x(a$y(b$z))} 0 } {- {$x(a$y(b$z))} 1 word {$x(a$y(b$z))} 8 variable {$x(a$y(b$z))} 7 text x 0 text a 0 variable {$y(b$z)} 4 text y 0 text b 0 variable {$z} 1 text z 0 {}} +test parse-12.26 {Tcl_ParseVarName [d2ffcca163] non-ascii} testparser { + testparser "$\u0433" -1 +} "- {$\u0433} 1 word {$\u0433} 2 text {$} 0 text \u0433 0 {}" test parse-13.1 {Tcl_ParseVar procedure} testparsevar { set abc 24 @@ -670,16 +678,36 @@ 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"} -test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { - testparser [bytestring "foo\0 bar"] -1 + 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 testbytestring} { + testparser [testbytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-14.2 {Tcl_ParseBraces procedure, computing string length} testparser { testparser "foo bar" -1 @@ -715,8 +743,8 @@ test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} testparser { list [catch {testparser "foo \{xy\\\nz" 0} msg] $msg $::errorInfo } {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"} -test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} testparser { - testparser [bytestring "foo\0 bar"] -1 +test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} {testparser testbytestring} { + testparser [testbytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} testparser { testparser "foo bar" -1 @@ -881,11 +909,11 @@ test parse-15.53 {CommandComplete procedure} " test parse-15.54 {CommandComplete procedure} " info complete \"foo bar;# \{\" " 1 -test parse-15.55 {CommandComplete procedure} { - info complete "set x [bytestring \0]; puts hi" +test parse-15.55 {CommandComplete procedure} testbytestring { + info complete "set x [testbytestring \0]; puts hi" } 1 -test parse-15.56 {CommandComplete procedure} { - info complete "set x [bytestring \0]; \{" +test parse-15.56 {CommandComplete procedure} testbytestring { + info complete "set x [testbytestring \0]; \{" } 0 test parse-15.57 {CommandComplete procedure} { info complete "# Comment should be complete command" @@ -893,9 +921,9 @@ test parse-15.57 {CommandComplete procedure} { test parse-15.58 {CommandComplete procedure, memory leaks} { info complete "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22" } 1 -test parse-15.59 {CommandComplete procedure} { +test parse-15.59 {CommandComplete procedure} testbytestring { # Test for Tcl Bug 684744 - info complete [encoding convertfrom identity "\x00;if 1 \{"] + info complete [testbytestring "\x00;if 1 \{"] } 0 test parse-15.60 {CommandComplete procedure} { # Test for Tcl Bug 1968882 @@ -1090,6 +1118,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..ef05454 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]] @@ -22,6 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # of "<<" are integers. testConstraint testexprparser [llength [info commands testexprparser]] +testConstraint testbytestring [llength [info commands testbytestring]] # Big test for correct ordering of data in [expr] @@ -83,8 +82,8 @@ testConstraint ieeeFloatingPoint [testIEEE] ###################################################################### -test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} testexprparser { - testexprparser [bytestring "1+2\0 +3"] -1 +test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {testexprparser testbytestring} { + testexprparser [testbytestring "1+2\0 +3"] -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser "1 + 2" -1 @@ -1065,7 +1064,16 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body { dict get $o -errorcode } -result {TCL PARSE EXPR BADNUMBER BINARY} +test parseExpr-22.19 {Bug d2ffcca163} -constraints testexprparser -body { + testexprparser \u0433 -1 +} -returnCodes error -match glob -result {*invalid character*} +test parseExpr-22.20 {Bug d2ffcca163} -constraints testexprparser -body { + testexprparser \u043f -1 +} -returnCodes error -match glob -result {*invalid character*} +test parseExpr-22.21 {Bug d2ffcca163} -constraints testexprparser -body { + testexprparser in\u0433(0) -1 +} -returnCodes error -match glob -result {missing operand*} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/parseOld.test b/tests/parseOld.test index 0edcbf0..a6e07a2b 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -13,15 +13,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 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testwordend [llength [info commands testwordend]] +testConstraint testbytestring [llength [info commands testbytestring]] # Save the argv value for restoration later set savedArgv $argv @@ -166,25 +165,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 +193,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 +210,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\]\}" @@ -263,15 +262,15 @@ test parseOld-7.10 {backslash substitution} { test parseOld-7.11 {backslash substitution} { eval "list a \"b c\"\\\nd e" } {a {b c} d e} -test parseOld-7.12 {backslash substitution} { - list \ua2 -} [bytestring "\xc2\xa2"] -test parseOld-7.13 {backslash substitution} { - list \u4e21 -} [bytestring "\xe4\xb8\xa1"] -test parseOld-7.14 {backslash substitution} { - list \u4e2k -} [bytestring "\xd3\xa2k"] +test parseOld-7.12 {backslash substitution} testbytestring { + expr {[list \ua2] eq [testbytestring "\xc2\xa2"]} +} 1 +test parseOld-7.13 {backslash substitution} testbytestring { + expr {[list \u4e21] eq [testbytestring "\xe4\xb8\xa1"]} +} 1 +test parseOld-7.14 {backslash substitution} testbytestring { + expr {[list \u4e2k] eq [testbytestring "\xd3\xa2k"]} +} 1 # Semi-colon. 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..a83c99b 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -241,13 +241,13 @@ test regexp-5.5 {exercise cache of compiled expressions} { test regexp-6.1 {regexp errors} { list [catch {regexp a} msg] $msg -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexp-6.2 {regexp errors} { list [catch {regexp -nocase a} msg] $msg -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexp-6.3 {regexp errors} { list [catch {regexp -gorp a} msg] $msg -} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} +} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexp-6.4 {regexp errors} { list [catch {regexp a( b} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -441,19 +441,19 @@ test regexp-10.5 {inverse partial newline sensitivity in regsub} { test regexp-11.1 {regsub errors} { list [catch {regsub a b} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.2 {regsub errors} { list [catch {regsub -nocase a b} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.3 {regsub errors} { list [catch {regsub -nocase -all a b} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.4 {regsub errors} { list [catch {regsub a b c d e f} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.5 {regsub errors} { list [catch {regsub -gorp a b c} msg] $msg -} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} test regexp-11.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -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/regexpComp.test b/tests/regexpComp.test index 94fb90e..01ef06d 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -316,17 +316,17 @@ test regexpComp-6.1 {regexp errors} { evalInProc { list [catch {regexp a} msg] $msg } -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexpComp-6.2 {regexp errors} { evalInProc { list [catch {regexp -nocase a} msg] $msg } -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexpComp-6.3 {regexp errors} { evalInProc { list [catch {regexp -gorp a} msg] $msg } -} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} +} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexpComp-6.4 {regexp errors} { evalInProc { list [catch {regexp a( b} msg] $msg @@ -526,6 +526,11 @@ test regexpComp-9.6 {-all option to regsub} { list [regsub -all ^ xxx 123 foo] $foo } } {1 123xxx} +test regexpComp-9.7 {Bug 84af1192f5: -all option to regsub} { + evalInProc { + regsub -all {\(.*} 123(qwe) "" + } +} 123 test regexpComp-10.1 {expanded syntax in regsub} { evalInProc { @@ -562,27 +567,27 @@ test regexpComp-11.1 {regsub errors} { evalInProc { list [catch {regsub a b} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.2 {regsub errors} { evalInProc { list [catch {regsub -nocase a b} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.3 {regsub errors} { evalInProc { list [catch {regsub -nocase -all a b} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.4 {regsub errors} { evalInProc { list [catch {regsub a b c d e f} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.5 {regsub errors} { evalInProc { list [catch {regsub -gorp a b c} msg] $msg } -} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} test regexpComp-11.6 {regsub errors} { evalInProc { list [catch {regsub -nocase a( b c d} msg] $msg 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 9f1cc78..4f90e51 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -64,7 +64,7 @@ package require tcltest 2 namespace import -force ::tcltest::* # Some tests require the Thread package or exec command -testConstraint thread [expr {0 == [catch {package require Thread 2.6.6}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint exec [llength [info commands exec]] # Produce a random port number in the Dynamic/Private range @@ -86,8 +86,21 @@ puts $s2 test1; gets $s1 puts $s2 test2; gets $s1 close $s1; close $s2 set t2 [clock milliseconds] -set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin -unset t1 t2 s1 s2 server +set lat1 [expr {($t2-$t1)*2}]; # doubled as a safety margin + +# Test the latency of failed connection attempts over the loopback +# interface. They can take more than a second under Windowos and requres +# additional [after]s in some tests that are not needed on systems that fail +# immediately. +set t1 [clock milliseconds] +catch {socket 127.0.0.1 [randport]} +set t2 [clock milliseconds] +set lat2 [expr {($t2-$t1)*3}] + +# Use the maximum of the two latency calculations, but at least 100ms +set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}] +set latency [expr {$latency > 100 ? $latency : 1000}] +unset t1 t2 s1 s2 lat1 lat2 server # If remoteServerIP or remoteServerPort are not set, check in the environment # variables for externally set values. @@ -124,7 +137,6 @@ foreach {af localhost} { testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}] catch {close $sock} } -testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}] set sock [socket -server foo -myaddr localhost 0] set sockname [fconfigure $sock -sockname] @@ -138,6 +150,9 @@ foreach {af localhost} { inet 127.0.0.1 inet6 ::1 } { + if {![testConstraint supported_$af]} { + continue + } set ::tcl::unsupported::socketAF $af # # Check if we're supposed to do tests against the remote server @@ -625,6 +640,86 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a close $s close $sock } -result {a:one b: c:two} +test socket_$af-2.12 {} [list socket stdio supported_$af] { + file delete $path(script) + set f [open $path(script) w] + puts $f { + set server [socket -server accept_client 0] + puts [lindex [chan configure $server -sockname] 2] + proc accept_client { client host port } { + chan configure $client -blocking 0 -buffering line + write_line $client + } + proc write_line client { + if { [catch { chan puts $client [string repeat . 720000]}] } { + puts [catch {chan close $client}] + } else { + puts signal1 + after 0 write_line $client + } + } + chan event stdin readable {set forever now} + vwait forever + exit + } + close $f + set f [open "|[list [interpreter] $path(script)]" r+] + gets $f port + set sock [socket $localhost $port] + chan event $sock readable [list read_lines $sock $f] + proc read_lines { sock pipe } { + gets $pipe + chan close $sock + chan event $pipe readable [list readpipe $pipe] + } + proc readpipe {pipe} { + while {![string is integer [set ::done [gets $pipe]]]} {} + } + vwait ::done + close $f + set ::done +} 0 +test socket_$af-2.13 {Bug 1758a0b603} {socket stdio} { + file delete $path(script) + set f [open $path(script) w] + puts $f { + set server [socket -server accept 0] + puts [lindex [chan configure $server -sockname] 2] + proc accept { client host port } { + chan configure $client -blocking 0 -buffering line -buffersize 1 + puts $client [string repeat . 720000] + puts ready + chan event $client writable [list setup $client] + } + proc setup client { + chan event $client writable {set forever write} + after 5 {set forever timeout} + } + vwait forever + puts $forever + } + close $f + set pipe [open |[list [interpreter] $path(script)] r] + gets $pipe port + set sock [socket $localhost $port] + chan configure $sock -blocking 0 -buffering line + chan event $sock readable [list read_lines $sock $pipe ] + proc read_lines { sock pipe } { + gets $pipe + gets $sock line + after idle [list stop $sock $pipe] + chan event $sock readable {} + } + proc stop {sock pipe} { + variable done + close $sock + set done [gets $pipe] + } + variable done + vwait [namespace which -variable done] + close $pipe + set done +} write test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) @@ -1560,8 +1655,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { close $f # If the socket doesn't hit end-of-file in 10 seconds, the script1 process # must have inherited the client. - set failed 0 - set after [after 10000 [list set failed 1]] + set timeout 0 + set after [after 10000 {set x "client socket was inherited"}] } -constraints [list socket supported_$af stdio exec] -body { # Create the server socket set server [socket -server accept -myaddr $localhost 0] @@ -1571,26 +1666,20 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { close $server fileevent $file readable [list getdata $file] fconfigure $file -buffering line -blocking 0 + set ::f $file } proc getdata { file } { # Read handler on the accepted socket. - global x failed + global x set status [catch {read $file} data] if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } + set x "read failed, error was $data" } elseif {$data ne ""} { } elseif {[fblocked $file]} { } elseif {[eof $file]} { - if {$failed} { - set x {client socket was inherited} - } else { - set x {client socket was not inherited} - } - catch { close $file } + set x "client socket was not inherited" } else { - set x {impossible case} - catch { close $file } + set x "impossible case" } } # Launch the script2 process @@ -1600,6 +1689,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { vwait x return $x } -cleanup { + fconfigure $f -blocking 1 + close $f after cancel $after close $p } -result {client socket was not inherited} @@ -1641,35 +1732,30 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { # If the socket is still open after 5 seconds, the script1 process must # have inherited the accepted socket. set failed 0 - set after [after 5000 [list set failed 1]] + set after [after 5000 [list set x "accepted socket was inherited"]] proc getdata { file } { # Read handler on the client socket. global x global failed set status [catch {read $file} data] if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } + set x "read failed, error was $data" } elseif {[string compare {} $data]} { } elseif {[fblocked $file]} { } elseif {[eof $file]} { - if {$failed} { - set x {accepted socket was inherited} - } else { - set x {accepted socket was not inherited} - } - catch { close $file } + set x "accepted socket was not inherited" } else { - set x {impossible case} - catch { close $file } + set x "impossible case" } return } vwait x - return $x + set x } -cleanup { + fconfigure $f -blocking 1 + close $f after cancel $after - catch {close $p} + close $p } -result {accepted socket was not inherited} test socket_$af-13.1 {Testing use of shared socket between two threads} -body { @@ -1723,8 +1809,8 @@ catch {close $commandSocket} catch {close $remoteProcChan} } unset ::tcl::unsupported::socketAF -test socket-14.0 {[socket -async] when server only listens on IPv4} \ - -constraints [list socket supported_any localhost_v4] \ +test socket-14.0.0 {[socket -async] when server only listens on IPv4} \ + -constraints {socket supported_inet localhost_v4} \ -setup { proc accept {s a p} { global x @@ -1736,7 +1822,29 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ set port [lindex [fconfigure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result ok +test socket-14.0.1 {[socket -async] when server only listens on IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] vwait x set x } -cleanup { @@ -1746,7 +1854,7 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ unset x } -result ok test socket-14.1 {[socket -async] fileevent while still connecting} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -setup { proc accept {s a p} { global x @@ -1763,7 +1871,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ lappend x [fconfigure $client -error] fileevent $client writable {} } - set after [after 1000 {lappend x timeout}] + set after [after $latency {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { vwait x } @@ -1775,26 +1883,21 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ unset x } -result {{} ok} test socket-14.2 {[socket -async] fileevent connection refused} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -body { - if {[catch {socket -async localhost [randport]} client]} { - regexp {[^:]*: (.*)} $client -> x - } else { - fileevent $client writable {set x [fconfigure $client -error]} - set after [after 1000 {set x timeout}] - vwait x - after cancel $after - if {$x eq "timeout"} { - append x ": [fconfigure $client -error]" - } - close $client - } - set x + set client [socket -async localhost [randport]] + fileevent $client writable {set x ok} + set after [after $latency {set x timeout}] + vwait x + after cancel $after + lappend x [fconfigure $client -error] } -cleanup { - unset x - } -result "connection refused" + after cancel $after + close $client + unset x after client + } -result {ok {connection refused}} test socket-14.3 {[socket -async] when server only listens on IPv6} \ - -constraints [list socket supported_any localhost_v6] \ + -constraints {socket supported_inet6 localhost_v6} \ -setup { proc accept {s a p} { global x @@ -1806,7 +1909,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ set port [lindex [fconfigure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after $latency {set x [fconfigure $client -error]}] vwait x set x } -cleanup { @@ -1816,7 +1919,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ unset x } -result ok test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -setup { proc accept {s a p} { puts $s bye @@ -1832,7 +1935,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ fileevent $client writable {} } fileevent $client readable {lappend x [gets $client]} - set after [after 1000 {lappend x timeout}] + set after [after $latency {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { vwait x } @@ -1841,15 +1944,466 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ after cancel $after close $client close $server + unset x } -result {{} bye} +# FIXME: we should also have an IPv6 counterpart of this test socket-14.5 {[socket -async] which fails before any connect() can be made} \ - -constraints [list socket supported_any] \ + -constraints {socket supported_inet} \ -body { # address from rfc5737 socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] } \ -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} +test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + 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] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result {ok bye} +test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result {ok bye} +test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok {}} +test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok {}} +test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + catch {gets $sock} x + list $x [fconfigure $sock -error] [fconfigure $sock -error] + } -cleanup { + close $sock + } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} +test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x + } -cleanup { + close $fd + close $sock + removeFile script + } -result {ok} +test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x + } -cleanup { + close $fd + close $sock + removeFile script + } -result {ok} +test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + list $x [fconfigure $sock -error] [fconfigure $sock -error] + } -cleanup { + close $sock + } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} +test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + puts $sock ok + fileevent $sock writable {set x 1} + vwait x + close $sock + } -cleanup { + catch {close $sock} + unset x + } -result {socket is not connected} -returnCodes 1 +test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ + -constraints {socket nonportable} \ + -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $sock writable {set x 1} + vwait x + close $sock + } -cleanup { + catch {close $sock} + catch {unset x} + } -result {socket is not connected} -returnCodes 1 +test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \ + -constraints {socket} \ + -body { + set s [socket -async localhost [randport]] + for {set i 0} {$i < 50} {incr i} { + set x [fconfigure $s -error] + if {$x != ""} break + after 200 + } + set x + } -cleanup { + close $s + unset x s + } -result {connection refused} + +test socket-14.13 {testing writable event when quick failure} \ + -constraints {socket win supported_inet} \ + -body { + # Test for bug 336441ed59 where a quick background fail was ignored + + # Test only for windows as socket -async 255.255.255.255 fails + # directly on unix + + # The following connect should fail very quickly + set a1 [after 2000 {set x timeout}] + set s [socket -async 255.255.255.255 43434] + fileevent $s writable {set x writable} + vwait x + set x +} -cleanup { + catch {close $s} + after cancel $a1 +} -result writable + +test socket-14.14 {testing fileevent readable on failed async socket connect} \ + -constraints {socket} -body { + # Test for bug 581937ab1e + + set a1 [after 5000 {set x timeout}] + # This connect should fail + set s [socket -async localhost [randport]] + fileevent $s readable {set x readable} + vwait x + set x +} -cleanup { + catch {close $s} + after cancel $a1 +} -result readable + +test socket-14.15 {blocking read on async socket should not trigger event handlers} \ + -constraints socket -body { + set s [socket -async localhost [randport]] + set x ok + fileevent $s writable {set x fail} + catch {read $s} + close $s + set x + } -result ok + +# v4 and v6 is required to prevent that the async connect does not terminate +# before the fconfigure command. There is always an additional ip to try. +test socket-14.16 {empty -peername while [socket -async] connecting} \ + -constraints {socket localhost_v4 localhost_v6} \ + -body { + set client [socket -async localhost [randport]] + fconfigure $client -peername + } -cleanup { + catch {close $client} + } -result {} + +# v4 and v6 is required to prevent that the async connect does not terminate +# before the fconfigure command. There is always an additional ip to try. +test socket-14.17 {empty -sockname while [socket -async] connecting} \ + -constraints {socket localhost_v4 localhost_v6} \ + -body { + set client [socket -async localhost [randport]] + fconfigure $client -sockname + } -cleanup { + catch {close $client} + } -result {} + +# test for bug c6ed4acfd8: running async socket connect with other connect +# established will block tcl as it goes in an infinite loop in vwait +test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} \ + -constraints {socket} \ + -body { + proc accept {channel address port} {} + set port [randport] + set ssock [socket -server accept $port] + set csock1 [socket -async localhost [randport]] + set csock2 [socket localhost $port] + after 1000 {set done ok} + vwait done +} -cleanup { + catch {close $ssock} + catch {close $csock1} + catch {close $csock2} + } -result {} + +set num 0 + +set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}} +set resultok {-result "sock*" -match glob} +set resulterr { + -result {couldn't open socket: connection refused} + -returnCodes 1 +} +foreach {servip sc} $x { + foreach {cliip cc} $x { + set constraints socket + lappend constraints $sc $cc + set result $resulterr + switch -- [lsort -unique [list $servip $cliip]] { + localhost - 127.0.0.1 - ::1 { + set result $resultok + } + {127.0.0.1 localhost} { + if {[testConstraint localhost_v4]} { + set result $resultok + } + } + {::1 localhost} { + if {[testConstraint localhost_v6]} { + set result $resultok + } + } + } + test socket-15.1.$num "Connect to $servip from $cliip" \ + -constraints $constraints -setup { + set server [socket -server accept -myaddr $servip 0] + proc accept {s h p} { close $s } + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set s [socket $cliip $port] + } -cleanup { + close $server + catch {close $s} + } {*}$result + incr num + } +} + ::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 e86c0de..3611753 100644 --- a/tests/string.test +++ b/tests/string.test @@ -30,7 +30,7 @@ testConstraint memory [llength [info commands memory]] test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2 {error conditions} { list [catch {string} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} @@ -54,7 +54,7 @@ test string-2.6 {string compare} { string compare abcde abdef } -1 test string-2.7 {string compare, shortest method name} { - string c abcde ABCDE + string co abcde ABCDE } 1 test string-2.8 {string compare} { string compare abcde abcde @@ -81,7 +81,7 @@ test string-2.13 {string compare -nocase} { string compare -nocase abcde abdef } -1 test string-2.14 {string compare -nocase} { - string c -nocase abcde ABCDE + string compare -nocase abcde ABCDE } 0 test string-2.15 {string compare -nocase} { string compare -nocase abcde abcde @@ -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 @@ -1396,6 +1398,9 @@ test string-15.9 {string tolower} { test string-15.10 {string tolower, unicode} { string tolower ABCabc\xc7\xe7 } "abcabc\xe7\xe7" +test string-15.11 {string tolower, compiled} { + lindex [string tolower [list A B [list C]]] 1 +} b test string-16.1 {string toupper} { list [catch {string toupper} msg] $msg @@ -1427,6 +1432,9 @@ test string-16.9 {string toupper} { test string-16.10 {string toupper, unicode} { string toupper ABCabc\xc7\xe7 } "ABCABC\xc7\xc7" +test string-16.11 {string toupper, compiled} { + lindex [string toupper [list a b [list c]]] 1 +} B test string-17.1 {string totitle} { list [catch {string totitle} msg] $msg @@ -1449,6 +1457,9 @@ test string-17.6 {string totitle, unicode} { test string-17.7 {string totitle, unicode} { string totitle \u01f3BCabc\xc7\xe7 } "\u01f2bcabc\xe7\xe7" +test string-17.8 {string totitle, compiled} { + lindex [string totitle [list aa bb [list cc]]] 0 +} Aa test string-18.1 {string trim} { list [catch {string trim} msg] $msg @@ -1484,8 +1495,8 @@ test string-18.11 {string trim, unicode} { string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8 } " AB\xe7C " test string-18.12 {string trim, unicode default} { - string trim ABC\u1361\u1680\u3000 -} ABC + string trim \ufeff\x00\u0085\u00a0\u1680\u180eABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000 +} ABC\u1361 test string-19.1 {string trimleft} { list [catch {string trimleft} msg] $msg @@ -1494,15 +1505,15 @@ test string-19.2 {string trimleft} { string trimleft " XYZ " } {XYZ } test string-19.3 {string trimleft, unicode default} { - string trimleft \u1361\u1680\u3000ABC -} ABC + string trimleft \ufeff\u0085\u00a0\x00\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000\u1361ABC +} \u1361ABC test string-20.1 {string trimright errors} { list [catch {string trimright} msg] $msg } {1 {wrong # args: should be "string trimright string ?chars?"}} test string-20.2 {string trimright errors} { list [catch {string trimg a} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3 {string trimright} { string trimright " XYZ " } { XYZ} @@ -1513,8 +1524,8 @@ test string-20.5 {string trimright} { string trimright "" } {} test string-20.6 {string trimright, unicode default} { - string trimright ABC\u1361\u1680\u3000 -} ABC + string trimright ABC\u1361\u0085\x00\u00a0\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000 +} ABC\u1361 test string-21.1 {string wordend} { list [catch {string wordend a} msg] $msg @@ -1561,7 +1572,7 @@ test string-21.14 {string wordend, unicode} { test string-22.1 {string wordstart} { list [catch {string word a} msg] $msg -} {1 {unknown or ambiguous subcommand "word": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2 {string wordstart} { list [catch {string wordstart a} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} @@ -1790,8 +1801,8 @@ test string-26.7 {tcl::prefix} -body { tcl::prefix match -exact {apa bepa cepa depa} be } -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa} test string-26.8 {tcl::prefix} -body { - tcl::prefix match -message switch {apa bepa bear depa} be -} -returnCodes 1 -result {ambiguous switch "be": must be apa, bepa, bear, or depa} + tcl::prefix match -message wombat {apa bepa bear depa} be +} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa} test string-26.9 {tcl::prefix} -body { tcl::prefix match -error {} {apa bepa bear depa} be } -returnCodes 0 -result {} @@ -1958,6 +1969,30 @@ test string-28.13 {tcl::prefix longest} { tcl::prefix longest {ax\x90 bep ax\x91} a } ax +test string-29.1 {string cat, no arg} { + string cat +} "" +test string-29.2 {string cat, single arg} { + set x FOO + string compare $x [string cat $x] +} 0 +test string-29.3 {string cat, two args} { + set x FOO + string compare $x$x [string cat $x $x] +} 0 +test string-29.4 {string cat, many args} { + set x FOO + set n 260 + set xx [string repeat $x $n] + set vv [string repeat {$x} $n] + set vvs [string repeat {$x } $n] + set r1 [string compare $xx [subst $vv]] + set r2 [string compare $xx [eval "string cat $vvs"]] + list $r1 $r2 +} {0 0} + + + # cleanup rename MemStress {} catch {rename foo {}} diff --git a/tests/stringComp.test b/tests/stringComp.test index 56fb69d..a66525e 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -26,11 +26,27 @@ catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testobj command testConstraint testobj [expr {[info commands testobj] != {}}] - +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} + test stringComp-1.1 {error conditions} { proc foo {} {string gorp a b} list [catch {foo} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test stringComp-1.2 {error conditions} { proc foo {} {string} list [catch {foo} msg] $msg @@ -194,7 +210,7 @@ foreach {tname tbody tresult tcode} { # need a few extra tests short abbr cmd test stringComp-3.1 {string compare, shortest method name} { - proc foo {} {string c abcde ABCDE} + proc foo {} {string co abcde ABCDE} foo } 1 test stringComp-3.2 {string equal, shortest method name} { @@ -677,13 +693,41 @@ test stringComp-11.54 {string match, failure} { } {0 1 1 1 0 0} ## string range -## not yet bc +test stringComp-12.1 {Bug 3588366: end-offsets before start} { + apply {s { + string range $s 0 end-5 + }} 12345 +} {} ## string repeat ## not yet bc ## string replace -## not yet bc +test stringComp-14.1 {Bug 82e7f67325} { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} +} {3 3} +test stringComp-14.2 {Bug 82e7f67325} memory { + # As in stringComp-14.1, but make sure we don't retain too many refs + leaktest { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} + } +} {0} +test stringComp-14.3 {Bug 0dca3bfa8f} { + apply {arg { + set argCopy $arg + set arg [string replace $arg 1 2 aa] + # Crashes in comparison before fix + expr {$arg ne $argCopy} + }} abcde +} 1 ## string tolower ## not yet bc @@ -700,7 +744,45 @@ test stringComp-11.54 {string match, failure} { ## string word* ## not yet bc +## string cat +test stringComp-29.1 {string cat, no arg} { + proc foo {} {string cat} + foo +} "" +test stringComp-29.2 {string cat, single arg} { + proc foo {} { + set x FOO + string compare $x [string cat $x] + } + foo +} 0 +test stringComp-29.3 {string cat, two args} { + proc foo {} { + set x FOO + string compare $x$x [string cat $x $x] + } + foo +} 0 +test stringComp-29.4 {string cat, many args} { + proc foo {} { + set x FOO + set n 260 + set xx [string repeat $x $n] + set vv [string repeat {$x} $n] + set vvs [string repeat {$x } $n] + set r1 [string compare $xx [subst $vv]] + set r2 [string compare $xx [eval "string cat $vvs"]] + list $r1 $r2 + } + foo +} {0 0} + + # cleanup catch {rename foo {}} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/stringObj.test b/tests/stringObj.test index 6f331d3..8209142 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -21,6 +21,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] test stringObj-1.1 {string type registration} testobj { @@ -338,7 +339,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr # Because this test does not use \uXXXX notation below instead of # hardcoding the values, it may fail in multibyte locales. However, we # need to test that the parser produces untyped objects even when there - # are high-ASCII characters in the input (like "ï"). I don't know what + # are high-ASCII characters in the input (like "ï"). I don't know what # else to do but inline those characters here. testdstring free testdstring append "abc\u00ef\u00efdef" -1 @@ -347,7 +348,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr [testobj objtype $x] [testobj objtype $y] } [list none "bc\u00EF\u00EFde" string string] test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { - # set x "abcïïdef" + # set x "abcïïdef" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set x "abc\u00EF\u00EFdef" @@ -356,7 +357,7 @@ test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { [testobj objtype $x] [testobj objtype $y] } [list string "bc\u00EF\u00EFde" string string] test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj { - # set a "ïa¿b®cï¿d®" + # set a "ïa¿b®cï¿d®" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" @@ -416,24 +417,24 @@ test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj { string length "\u00ae" } 1 test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj { - # string length "￮￮" + # string length "￮￮" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE" } 6 test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj { - # set a "ïa¿b®cï¿d®" + # set a "ïa¿b®cï¿d®" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" list [string length $a] [string length $a] } {10 10} -test stringObj-13.7 {Tcl_GetCharLength with identity nulls} testobj { +test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} { # SF bug #684699 - string length [encoding convertfrom identity \x00] + string length [testbytestring \x00] } 1 -test stringObj-13.8 {Tcl_GetCharLength with identity nulls} testobj { - string length [encoding convertfrom identity \x01\x00\x02] +test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} { + string length [testbytestring \x01\x00\x02] } 3 test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj { diff --git a/tests/subst.test b/tests/subst.test index 4be4798..2115772 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -15,13 +15,17 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint testbytestring [llength [info commands testbytestring]] test subst-1.1 {basics} -returnCodes error -body { subst } -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"} test subst-1.2 {basics} -returnCodes error -body { subst a b c -} -result {bad switch "a": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "a": must be -nobackslashes, -nocommands, or -novariables} test subst-2.1 {simple strings} { subst {} @@ -32,16 +36,16 @@ test subst-2.2 {simple strings} { test subst-2.3 {simple strings} { subst abcdefg } abcdefg -test subst-2.4 {simple strings} { +test subst-2.4 {simple strings} testbytestring { # Tcl Bug 685106 - subst [bytestring bar\x00soom] -} [bytestring bar\x00soom] + expr {[subst [testbytestring bar\x00soom]] eq [testbytestring bar\x00soom]} +} 1 test subst-3.1 {backslash substitutions} { subst {\x\$x\[foo bar]\\} } "x\$x\[foo bar]\\" test subst-3.2 {backslash substitutions with utf chars} { - # 'j' is just a char that doesn't mean anything, and \344 is 'ä' + # 'j' is just a char that doesn't mean anything, and \344 is 'ä' # that also doesn't mean anything, but is multi-byte in UTF-8. list [subst \j] [subst \\j] [subst \\344] [subst \\\344] } "j j \344 \344" @@ -119,13 +123,13 @@ test subst-6.1 {clear the result after command substitution} -body { test subst-7.1 {switches} -returnCodes error -body { subst foo bar -} -result {bad switch "foo": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "foo": must be -nobackslashes, -nocommands, or -novariables} test subst-7.2 {switches} -returnCodes error -body { subst -no bar -} -result {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables} +} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables} test subst-7.3 {switches} -returnCodes error -body { subst -bogus bar -} -result {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables} test subst-7.4 {switches} { set x 123 subst -nobackslashes {abc $x [expr 1+2] \\\x41} @@ -293,6 +297,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/switch.test b/tests/switch.test index a03948b..4d204bb 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -169,7 +169,7 @@ test switch-4.1 {error in executed command} { "switch a a {error "Just a test"} default {subst 1}"}} test switch-4.2 {error: not enough args} -returnCodes error -body { switch -} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"} +} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"} test switch-4.3 {error: pattern with no body} -body { switch a b } -returnCodes error -result {extra switch pattern with no body} @@ -269,16 +269,16 @@ test switch-8.3 {weird body text, variable} { test switch-9.1 {empty pattern/body list} -returnCodes error -body { switch x -} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"} +} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"} test switch-9.2 {unpaired pattern} -returnCodes error -body { switch -- x } -result {extra switch pattern with no body} test switch-9.3 {empty pattern/body list} -body { switch x {} -} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"} +} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"} test switch-9.4 {empty pattern/body list} -body { switch -- x {} -} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"} +} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"} test switch-9.5 {unpaired pattern} -body { switch x a {} b } -returnCodes error -result {extra switch pattern with no body} diff --git a/tests/tailcall.test b/tests/tailcall.test index 2d04f82..26f3cbf 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -147,6 +147,36 @@ test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup rename b {} } -result {0 0 0 0 0 0} +test tailcall-0.5.1 {tailcall is constant space} -constraints testnrelevels -setup { + # + # This test is related to [bug d87cb182053fd79b3]: the fix to that bug was + # to remove a call to TclSkipTailcall, which caused a violation of the + # constant-space property of tailcall in that particular + # configuration. This test was added to detect that, and insure that the + # problem is fixed. + # + + proc b i { + if {$i == 1} { + depthDiff + } + if {[incr i] > 10} { + return [depthDiff] + } + tailcall dict b $i + } + set map0 [namespace ensemble configure dict -map] + set map $map0 + dict set map b b + namespace ensemble configure dict -map $map +} -body { + dict b 0 +} -cleanup { + rename b {} + namespace ensemble configure dict -map $map0 + unset map map0 +} -result {0 0 0 0 0 0} + test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup { # # This test fails because ns-unknown is not NR-enabled diff --git a/tests/tcltest.test b/tests/tcltest.test index 86aca6f..e66678b 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] @@ -147,7 +142,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { } {0 1 1 1 1} test tcltest-2.6 {tcltest -verbose 't'} { - -constraints {unixOrPc} + -constraints {unixOrPc} -body { set result [slave msg test.tcl -verbose 't'] list $result $msg @@ -157,7 +152,7 @@ test tcltest-2.6 {tcltest -verbose 't'} { } test tcltest-2.6a {tcltest -verbose 'start'} { - -constraints {unixOrPc} + -constraints {unixOrPc} -body { set result [slave msg test.tcl -verbose start] list $result $msg @@ -174,7 +169,7 @@ test tcltest-2.7 {tcltest::verbose} { verbose foo set newVerbosity [verbose] verbose $oldVerbosity - list $currentVerbosity $newVerbosity + list $currentVerbosity $newVerbosity } -result {body {}} } @@ -222,7 +217,7 @@ test tcltest-3.5 {tcltest::match} { } -result {foo bar} } - + # -skip, [skip] test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { set result [slave msg test.tcl -skip a* -verbose 'ps'] @@ -304,8 +299,8 @@ test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} { # -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} # -cleanup { # set ::tcltest::constraintsSpecified $constraintlist -# unset ::tcltest::testConstraints(tcltestFakeConstraint1) -# unset ::tcltest::testConstraints(tcltestFakeConstraint2) +# unset ::tcltest::testConstraints(tcltestFakeConstraint1) +# unset ::tcltest::testConstraints(tcltestFakeConstraint2) # } #} @@ -353,7 +348,7 @@ set printerror [makeFile { ::tcltest::PrintError "a really really long string containing a \ \"Path/that/is/really/long/and/contains/no/spaces\"" ::tcltest::PrintError "a really really long string containing a \ - \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" + \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\"" exit } printerror.tcl] @@ -372,7 +367,7 @@ test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} { set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ - $result1 $result2 [file exists a.tmp] [file delete a.tmp] + $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {0 1 0 1 1 {}} test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} { slave msg $printerror -errfile a.tmp @@ -418,7 +413,7 @@ test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { set f2 [errorFile $ef] set f3 [errorChannel] set f4 [errorFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -454,7 +449,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { set f2 [outputFile $ef] set f3 [outputChannel] set f4 [outputFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -549,13 +544,13 @@ 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 } default { catch {file attributes $notWriteableDir -readonly 1} - catch {testchmod 000 $notWriteableDir} + catch {testchmod 0 $notWriteableDir} } } test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { @@ -716,18 +711,18 @@ 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 } default { - catch {testchmod 777 $notWriteableDir} + catch {testchmod 0o777 $notWriteableDir} catch {file attributes $notWriteableDir -readonly 0} } } -file delete -force $notReadableDir $notWriteableDir +file delete -force -- $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory @@ -763,7 +758,7 @@ test tcltest-9.3 {matchFiles} { set new [matchFiles] matchFiles $old list $current $new - } + } -result {foo bar} } @@ -776,7 +771,7 @@ test tcltest-9.4 {skipFiles} { set new [skipFiles] skipFiles $old list $current $new - } + } -result {foo bar} } @@ -1150,8 +1145,8 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { } -cleanup { interp delete slave2 interp delete slave1 - if {$oldoptions == "none"} { - unset ::env(TCLTEST_OPTIONS) + if {$oldoptions eq "none"} { + unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } @@ -1265,7 +1260,7 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} { } set foo 1 set expected 2 - } + } -body { incr foo set foo @@ -1429,7 +1424,7 @@ test tcltest-23.1 {makeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {1 1} } @@ -1452,7 +1447,7 @@ test tcltest-23.2 {removeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {0 0} } diff --git a/tests/thread.test b/tests/thread.test index 43222ac..f32ef61 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -25,7 +25,7 @@ testConstraint testthread [expr {[info commands testthread] != {}}] # Some tests require the Thread package -testConstraint thread [expr {0 == [catch {package require Thread 2.7}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # Some tests may not work under valgrind @@ -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..2d227fe 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -59,7 +59,7 @@ if {[testConstraint unix]} { } proc openup {path} { - testchmod 777 $path + testchmod 0o777 $path if {[file isdirectory $path]} { catch { foreach p [glob -directory $path *] { @@ -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/unixNotfy.test b/tests/unixNotfy.test index 0646a3d..2f03529 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -17,7 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # When run in a Tk shell, these tests hang. testConstraint noTk [expr {0 != [catch {package present Tk}]}] -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # Darwin always uses a threaded notifier testConstraint unthreaded [expr { ![::tcl::pkgconfig get threaded] 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..5ea870d 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -339,7 +339,7 @@ test upvar-8.9 {upvar won't create namespace variable that refers to procedure v unset ::test_ns_1::a } MakeLink 1 -} -result {bad variable name "a": upvar won't create namespace variable that refers to procedure variable} +} -result {bad variable name "a": can't create namespace variable that refers to procedure variable} test upvar-8.10 {upvar will create element alias for new array element} -setup { catch {unset upvarArray} } -body { @@ -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,37 @@ 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..ceb1af7 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -16,50 +16,52 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +testConstraint testbytestring [llength [info commands testbytestring]] + catch {unset x} -test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { - set x \x01 -} [bytestring "\x01"] -test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} { - set x "\x00" -} [bytestring "\xc0\x80"] -test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} { - set x "\xe0" -} [bytestring "\xc3\xa0"] -test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} { - set x "\u4e4e" -} [bytestring "\xe4\xb9\x8e"] -test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} { - format %c 0x110000 -} [bytestring "\xef\xbf\xbd"] -test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} { - format %c -1 -} [bytestring "\xef\xbf\xbd"] +test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring { + expr {"\x01" eq [testbytestring "\x01"]} +} 1 +test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { + expr {"\x00" eq [testbytestring "\xc0\x80"]} +} 1 +test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { + expr {"\xe0" eq [testbytestring "\xc3\xa0"]} +} 1 +test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring { + expr {"\u4e4e" eq [testbytestring "\xe4\xb9\x8e"]} +} 1 +test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { + expr {[format %c 0x110000] eq [testbytestring "\xef\xbf\xbd"]} +} 1 +test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { + expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]} +} 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" } {3} -test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} { - string length [bytestring "\x82\x83\x84"] +test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring { + string length [testbytestring "\x82\x83\x84"] } {3} -test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} { - string length [bytestring "\xC2"] +test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} testbytestring { + string length [testbytestring "\xC2"] } {1} -test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} { - string length [bytestring "\xC2\xa2"] +test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} testbytestring { + string length [testbytestring "\xC2\xa2"] } {1} -test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} { - string length [bytestring "\xE2"] +test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} testbytestring { + string length [testbytestring "\xE2"] } {1} -test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} { - string length [bytestring "\xE2\xA2"] +test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring { + string length [testbytestring "\xE2\xA2"] } {2} -test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} { - string length [bytestring "\xE4\xb9\x8e"] +test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { + string length [testbytestring "\xE4\xb9\x8e"] } {1} -test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} { - string length [bytestring "\xF4\xA2\xA2\xA2"] +test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring { + string length [testbytestring "\xF4\xA2\xA2\xA2"] } {4} test utf-3.1 {Tcl_UtfCharComplete} { @@ -69,26 +71,26 @@ testConstraint testnumutfchars [llength [info commands testnumutfchars]] test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars { testnumutfchars "" } {0} -test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars { - testnumutfchars [bytestring "\xC2\xA2"] +test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "\xC2\xA2"] } {1} -test utf-4.3 {Tcl_NumUtfChars: long string} testnumutfchars { - testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] +test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] } {7} -test utf-4.4 {Tcl_NumUtfChars: #u0000} testnumutfchars { - testnumutfchars [bytestring "\xC0\x80"] +test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "\xC0\x80"] } {1} test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars { testnumutfchars "" 1 } {0} -test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} testnumutfchars { - testnumutfchars [bytestring "\xC2\xA2"] 1 +test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "\xC2\xA2"] 1 } {1} -test utf-4.7 {Tcl_NumUtfChars: long string, calc len} testnumutfchars { - testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1 +test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1 } {7} -test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} testnumutfchars { - testnumutfchars [bytestring "\xC0\x80"] 1 +test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring "\xC0\x80"] 1 } {1} test utf-5.1 {Tcl_UtfFindFirsts} { @@ -125,18 +127,18 @@ test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { set x \n } { } -test utf-10.2 {Tcl_UtfBackslash: \u subst} { - set x \ua2 -} [bytestring "\xc2\xa2"] -test utf-10.3 {Tcl_UtfBackslash: longer \u subst} { - set x \u4e21 -} [bytestring "\xe4\xb8\xa1"] -test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} { - set x \u4e2k -} "[bytestring \xd3\xa2]k" -test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} { - set x \u4e216 -} "[bytestring \xe4\xb8\xa1]6" +test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring { + expr {"\ua2" eq [testbytestring "\xc2\xa2"]} +} 1 +test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring { + expr {"\u4e21" eq [testbytestring "\xe4\xb8\xa1"]} +} 1 +test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { + expr {"\u4e2k" eq "[testbytestring \xd3\xa2]k"} +} 1 +test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { + expr {"\u4e216" eq "[testbytestring \xe4\xb8\xa1]6"} +} 1 proc bsCheck {char num} { global errNum test utf-10.$errNum {backslash substitution} { @@ -285,23 +287,25 @@ test utf-18.5 {Tcl_UniCharToTitle, no delta} { string totitle ! } ! -test utf-19.1 {TclUniCharLen} { +test utf-19.1 {TclUniCharLen} -body { list [regexp \\d abc456def foo] $foo -} {1 4} +} -cleanup { + unset -nocomplain foo +} -result {1 4} test utf-20.1 {TclUniCharNcmp} { } {} test utf-21.1 {TclUniCharIsAlnum} { - # this returns 1 with Unicode 6 compliance + # this returns 1 with Unicode 7 compliance string is alnum \u1040\u021f\u0220 } {1} test utf-21.2 {unicode alnum char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance + # this returns 1 with Unicode 7 compliance list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220] } {1 1} test utf-21.3 {unicode print char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance + # this returns 1 with Unicode 7 compliance regexp {^[[:print:]]+$} \ufbc1 } 1 test utf-21.4 {TclUniCharIsGraph} { @@ -334,11 +338,11 @@ test utf-21.10 {unicode print char in regc_locale.c} { } {0} test utf-21.11 {TclUniCharIsControl} { # [Bug 3464428] - string is control \u00ad + string is control \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff } {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\u0605\u061c\u180e\u2066\ufeff } {1} test utf-22.1 {TclUniCharIsWordChar} { @@ -349,30 +353,30 @@ test utf-22.2 {TclUniCharIsWordChar} { } 10 test utf-23.1 {TclUniCharIsAlpha} { - # this returns 1 with Unicode 6 compliance - string is alpha \u021f\u0220 + # this returns 1 with Unicode 7 compliance + string is alpha \u021f\u0220\u037f\u052f } {1} test utf-23.2 {unicode alpha char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance - regexp {^[[:alpha:]]+$} \u021f\u0220 + # this returns 1 with Unicode 7 compliance + regexp {^[[:alpha:]]+$} \u021f\u0220\u037f\u052f } {1} test utf-24.1 {TclUniCharIsDigit} { - # this returns 1 with Unicode 6 compliance + # this returns 1 with Unicode 7 compliance string is digit \u1040\uabf0 } {1} test utf-24.2 {unicode digit char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance + # this returns 1 with Unicode 7 compliance list [regexp {^[[:digit:]]+$} \u1040\uabf0] [regexp {^\d+$} \u1040\uabf0] } {1 1} test utf-24.3 {TclUniCharIsSpace} { - # this returns 1 with Unicode 6 compliance - string is space \u1680\u180e + # this returns 1 with Unicode 7/TIP 413 compliance + string is space \u0085\u1680\u180e\u200b\u202f\u2060 } {1} test utf-24.4 {unicode space char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance - list [regexp {^[[:space:]]+$} \u1680\u180e] [regexp {^\s+$} \u1680\u180e] + # this returns 1 with Unicode 7/TIP 413 compliance + list [regexp {^[[:space:]]+$} \u0085\u1680\u180e\u200b\u202f\u2060] [regexp {^\s+$} \u0085\u1680\u180e\u200b\u202f\u2060] } {1 1} testConstraint teststringobj [llength [info commands teststringobj]] diff --git a/tests/util.test b/tests/util.test index 0e50483..7782f35 100644 --- a/tests/util.test +++ b/tests/util.test @@ -16,6 +16,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint controversialNaN 1 +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] testConstraint testdoubledigits [llength [info commands testdoubledigits]] @@ -274,10 +275,10 @@ test util-5.17 {Tcl_StringMatch: UTF-8} { # get 1 UTF-8 character Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc" } 1 -test util-5.18 {Tcl_StringMatch: UTF-8} { +test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # proper advance: wrong answer would match on UTF trail byte of \u4e4f - Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [bytestring a\u008fc] + Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\u008fc] } 0 test util-5.19 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); diff --git a/tests/var.test b/tests/var.test index ed7e930..7ff394e 100644 --- a/tests/var.test +++ b/tests/var.test @@ -289,7 +289,7 @@ test var-3.11 {MakeUpvar, my var looks like array elem} -setup { } -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa foo(bar) -} -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} +} -result {bad variable name "foo(bar)": can't create a scalar variable that looks like an array element} test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { catch {unset a} @@ -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,104 @@ 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-20.9 {[bc1a96407a] array set compiled w/ trace} -setup { + variable foo + variable lambda + unset -nocomplain lambda foo + array set foo {} + lappend lambda {} + lappend lambda [list array set [namespace which -variable foo] {a 1}] +} -body { + after 0 [list apply $lambda] + vwait [namespace which -variable foo] +} -cleanup { + unset -nocomplain lambda foo +} -result {} +test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body { + apply {{} {set name foo(bar); array set $name {a 1}}} +} -returnCodes error -match glob -result * + +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/winDde.test b/tests/winDde.test index 8d9bd12..f04fb45 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -20,7 +20,7 @@ testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.4.0b1] + set ::ddever [package require dde 1.4.0] set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { testConstraint dde 1 } @@ -104,7 +104,7 @@ proc createChildProcess {ddeServerName args} { # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.4.0b1} +} {1.4.0} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] @@ -203,8 +203,8 @@ test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body { set \xe1 "" set name ch\xEDld-4.3 set child [createChildProcess $name] - dde execute TclEval $name [list set a foo] - set \xe1 [dde request TclEval $name a] + dde execute TclEval $name [list set \xe1 foo] + set \xe1 [dde request TclEval $name \xe1] dde execute TclEval $name {set done 1} update set \xe1 diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 28a0e9f..a808c82 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -208,22 +208,11 @@ test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup { } -constraints {win win2000orXP testfile} -body { testfile mv nul tf1 } -returnCodes error -result EINVAL -test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} -setup { +test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { cleanup } -constraints {win nt winOlderThan2000 testfile} -body { testfile mv nul tf1 } -returnCodes error -result EACCES -test winFCmd-1.13.2 {TclpRenameFile: errno: ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result ENOENT -test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - testfile mv tf1 nul -} -returnCodes error -result EACCES test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup { cleanup } -constraints {win nt testfile} -body { @@ -257,11 +246,6 @@ test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup { } -constraints {win nt winOlderThan2000 testfile} -body { testfile mv nul tf1 } -returnCodes error -result EACCES -test winFCmd-1.19.2 {TclpRenameFile: errno == ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result ENOENT test winFCmd-1.20 {TclpRenameFile: src is dir} -setup { cleanup } -constraints {win nt testfile} -body { @@ -351,12 +335,12 @@ test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup { test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \ -constraints {win exdev testfile testchmod} -body { file mkdir d:/td1 - testchmod 000 d:/td1 + testchmod 0 d:/td1 file mkdir c:/tf1 catch {testfile mv c:/tf1 d:/td1} msg list $msg [file writable d:/td1] } -cleanup { - catch {testchmod 666 d:/td1} + catch {testchmod 0o666 d:/td1} file delete d:/td1 file delete -force c:/tf1 } -result {EXDEV 0} @@ -474,29 +458,14 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup { } -returnCodes error -result ENOENT test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup { cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - set fd [open tf2 w] - testfile cp tf1 tf2 -} -cleanup { - close $fd - cleanup -} -returnCodes error -result EACCES -test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { - cleanup } -constraints {win win2000orXP testfile} -body { testfile cp nul tf1 } -returnCodes error -result EINVAL -test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} -setup { +test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { cleanup } -constraints {win nt winOlderThan2000 testfile} -body { testfile cp nul tf1 } -returnCodes error -result EACCES -test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result ENOENT test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { @@ -520,11 +489,11 @@ test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { createfile tf1 tf1 - testchmod 000 tf1 + testchmod 0 tf1 testfile cp tf1 tf2 list [contents tf2] [file writable tf2] } -cleanup { - catch {testchmod 666 tf1} + catch {testchmod 0o666 tf1} cleanup } -result {tf1 0} test winFCmd-2.13 {TclpCopyFile: CopyFile fails} -setup { @@ -566,24 +535,13 @@ test winFCmd-2.17 {TclpCopyFile: dst is readonly} -setup { } -constraints {win testfile testchmod} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 000 tf2 + testchmod 0 tf2 testfile cp tf1 tf2 list [file writable tf2] [contents tf2] } -cleanup { - catch {testchmod 666 tf2} + catch {testchmod 0o666 tf2} cleanup } -result {1 tf1} -test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} -setup { - cleanup -} -constraints {win 95 testfile testchmod} -body { - createfile tf1 - createfile tf2 - testchmod 000 tf2 - set fd [open tf2] - set msg [list [catch {testfile cp tf1 tf2} msg] $msg] - close $fd - lappend msg [file writable tf2] -} -result {1 EACCES 0} test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} -body { testfile rm $cdfile $cdrom/dummy~~.fil @@ -647,7 +605,7 @@ test winFCmd-3.10 {TclpDeleteFile: path is readonly} -setup { cleanup } -constraints {win testfile testchmod} -body { createfile tf1 - testchmod 000 tf1 + testchmod 0 tf1 testfile rm tf1 file exists tf1 } -result {0} @@ -655,20 +613,17 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup { cleanup } -constraints {win testfile testchmod} -body { set fd [open tf1 w] - testchmod 000 tf1 + testchmod 0 tf1 testfile rm tf1 } -cleanup { close $fd - catch {testchmod 666 tf1} + catch {testchmod 0o666 tf1} cleanup } -returnCodes error -result EACCES test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body { testfile mkdir $cdrom/dummy~~.dir } -constraints {win nt cdrom testfile} -returnCodes error -result EACCES -test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} -body { - testfile mkdir $cdrom/dummy~~.dir -} -constraints {win 95 cdrom testfile} -returnCodes error -result ENOSPC test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup { cleanup } -constraints {win testfile} -body { @@ -703,11 +658,11 @@ test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup { cleanup } -constraints {winVista testfile testchmod} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir td1 file exists td1 } -returnCodes error -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -result {td1 EACCES} # This next test has a very hokey way of matching... @@ -757,18 +712,13 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { cleanup } -constraints {winVista testfile testchmod} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir td1 file exists td1 } -returnCodes error -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -result {td1 EACCES} -test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile rmdir nul -} -returnCodes error -result {nul EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup } -constraints {win nt testfile} -body { @@ -776,38 +726,18 @@ test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { # WinXP returns EEXIST, WinNT seems to return EACCES. No policy # decision has been made as to which is correct. } -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$} -# This next test has a very hokey way of matching... -test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} -setup { - cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - set res [catch {testfile rmdir tf1} msg] - # get rid of path - set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]] - list $res $msg -} -result {1 {tf1 ENOTDIR}} test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup } -constraints {winVista testfile testchmod} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir td1 file exists td1 } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -returnCodes error -result {td1 EACCES} # This next test has a very hokey way of matching... -test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1/td2 - set res [catch {testfile rmdir td1} msg] - # get rid of path - set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]] - list $res $msg -} -result {1 {td1 EEXIST}} -# This next test has a very hokey way of matching... test winFCmd-6.15 {TclpRemoveDirectory: !recursive} -setup { cleanup } -constraints {win testfile} -body { @@ -887,11 +817,6 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup { } -cleanup { cleanup } -result {tf1} -test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} -body { - # cdrom can return either d:\ or D:/, but we only care about the errcode - testfile rmdir $cdrom/ -} -constraints {win 95 cdrom testfile} -returnCodes error -match glob \ - -result {* EACCES} ; # was EEXIST, but changed for win98. test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body { testfile rmdir $cdrom/ } -constraints {win nt cdrom testfile} -returnCodes error -match glob \ @@ -905,11 +830,11 @@ test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} -setup { } -constraints {win testfile testchmod} -body { file mkdir td1 createfile td1/tf1 tf1 - testchmod 000 td1 + testchmod 0 td1 testfile cpdir td1 td2 list [file exists td2] [file writable td2] } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -result {1 1} test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} -setup { @@ -930,14 +855,6 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup { } -cleanup { cleanup } -result {tf1} -test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1 - testfile cpdir td1 / -} -cleanup { - cleanup -} -returnCodes error -result {/ EEXIST} test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup { cleanup } -constraints {win nt testfile} -body { @@ -984,11 +901,11 @@ test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} -setup { } -constraints {win testfile testchmod} -body { file mkdir td1 createfile td1/tf1 tf1 - testchmod 000 td1 + testchmod 0 td1 testfile cpdir td1 td2 list [file exists td2] [file writable td2] } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -result {1 1} test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} -setup { @@ -1015,11 +932,11 @@ test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} -setup { cleanup } -constraints {win testfile testchmod} -body { file mkdir td1/td2 - testchmod 000 td1 + testchmod 0 td1 testfile cpdir td1 td2 list [file writable td1] [file writable td1/td2] } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -result {0 1} test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} -setup { @@ -1038,24 +955,15 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup { createfile td1/tf1 testfile rmdir -force td1 } -result {} -test winFCmd-9.2 {TraversalDelete: DOTREE_F} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1 - set fd [open td1/tf1 w] - testfile rmdir -force td1 -} -cleanup { - close $fd -} -returnCodes error -result {td1\tf1 EACCES} test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup { cleanup } -constraints {winVista testfile testchmod} -body { file mkdir td1/td2 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir -force td1 file exists td1 } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -returnCodes error -result {td1 EACCES} test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} -setup { @@ -1406,14 +1314,14 @@ test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body { file pathtype com4 } -result "absolute" test winFCmd-18.1.3 {Windows reserved path names} -constraints win -body { - file pathtype com5 -} -result "relative" + file pathtype com9 +} -result "absolute" test winFCmd-18.1.4 {Windows reserved path names} -constraints win -body { file pathtype lpt3 } -result "absolute" test winFCmd-18.1.5 {Windows reserved path names} -constraints win -body { - file pathtype lpt4 -} -result "relative" + file pathtype lpt9 +} -result "absolute" test winFCmd-18.1.6 {Windows reserved path names} -constraints win -body { file pathtype nul } -result "absolute" @@ -1477,10 +1385,10 @@ test winFCmd-19.5 {Windows extended path names} -constraints nt -setup { list [catch { set f [open $tmpfile [list WRONLY CREAT]] close $f - } res] errormsg ;#$res + } res] $res } -cleanup { catch {file delete $tmpfile} -} -result [list 1 errormsg] +} -result [list 0 {}] test winFCmd-19.6 {Windows extended path names} -constraints nt -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile //?/[file normalize $tmpfile] @@ -1515,6 +1423,11 @@ test winFCmd-19.8 {Windows extended path names} -constraints nt -setup { catch {file delete $tmpfile} } -result [list 0 {} [list "tcl[pid].tmp "]] +test winFCmd-19.9 {Windows devices path names} -constraints nt -body { + file normalize //./com1 +} -result //./com1 + + # This block of code used to occur after the "return" call, so I'm # commenting it out and assuming that this code is still under construction. #foreach source {tef ted tnf tnd "" nul com1} { diff --git a/tests/winFile.test b/tests/winFile.test index fba9bcb..2c47f5f 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -37,24 +37,6 @@ test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body { # The administrator account should always exist. glob ~administrator } -match glob -result * -test winFile-1.3 {TclpGetUserHome} -constraints {win 95} -body { - # Find some user in system.ini and then see if they have a home. - - set f [open $::env(windir)/system.ini] - while {[gets $f line] >= 0} { - if {$line ne {[Password Lists]}} { - continue - } - gets $f - set name [lindex [split [gets $f] =] 0] - if {$name ne ""} { - return [catch {glob ~$name}] - } - } - return 0 ;# didn't find anything... -} -cleanup { - catch {close $f} -} -result {0} test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} { catch {glob ~stanton@workgroup} } {0} diff --git a/tests/winPipe.test b/tests/winPipe.test index d2e804d..9c6f94d 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -82,10 +82,6 @@ test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat3 exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" -test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {win 95 exec cat32} { - exec command /c type $path(big) |& $cat32 > $path(stdout) 2> $path(stderr) - list [contents $path(stdout)] [contents $path(stderr)] -} "{$big} stderr32" test winpipe-1.6 {32 bit comprehensive tests: from console} \ {win cat32 AllocConsole} { # would block waiting for human input @@ -174,10 +170,6 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \ catch {close $f} set r } "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" -test winpipe-1.22 {Checking command.com for Win95/98 hanging} {win 95 exec} { - exec command.com /c dir /b - set result 1 -} 1 test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { proc readResults {f} { diff --git a/tests/zlib.test b/tests/zlib.test index 8212082..b1d43fb 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -10,12 +10,19 @@ # 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.1 namespace import -force ::tcltest::* } 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 @@ -23,6 +30,12 @@ test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body { test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body { zlib ? {} } -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream} +test zlib-1.3 {zlib basics} -constraints zlib -body { + zlib::pkgconfig list +} -result zlibVersion +test zlib-1.4 {zlib basics} -constraints zlib -body { + package present zlib +} -result 2.0.1 test zlib-2.1 {zlib compress/decompress} zlib { zlib decompress [zlib compress abcdefghijklm] @@ -70,7 +83,7 @@ test zlib-7.0 {zlib stream} -constraints zlib -returnCodes error -setup { $s ? } -cleanup { $s close -} -result {bad option "?": must be add, checksum, close, eof, finalize, flush, fullflush, get, put, or reset} +} -result {bad option "?": must be add, checksum, close, eof, finalize, flush, fullflush, get, header, put, or reset} test zlib-7.1 {zlib stream} zlib { set s [zlib stream compress] $s put -finalize abcdeEDCBA @@ -202,7 +215,186 @@ test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup { set ::res } -cleanup { catch {close $r} -} -result {qwertyuiop MIDDLE asdfghjkl} +} -result {qwertyuiop MIDDLE asdfghjkl {}} +test zlib-8.6 {transformation and fconfigure} -setup { + set file [makeFile {} test.z] + set fd [open $file wb] +} -constraints zlib -body { + list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \ + [chan pop $fd; fconfigure $fd] +} -cleanup { + catch {close $fd} + removeFile $file +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +test zlib-8.7 {transformation and fconfigure} -setup { + set file [makeFile {} test.gz] + set fd [open $file wb] +} -constraints zlib -body { + list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \ + [chan pop $fd; fconfigure $fd] +} -cleanup { + catch {close $fd} + removeFile $file +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +# Input is headers from fetching SPDY draft +# 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 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push compress $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 decompress $compressed} err opt + list [string length [zlib compress $spdyHeaders]] \ + [string length $compressed] \ + $err [dict get $opt -errorcode] [zlib adler32 $spdyDict] +} -cleanup { + catch {close $outSide} + catch {close $inSide} +} -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} +test zlib-8.9 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream decompress] +} -constraints zlib -body { + zlib push compress $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + set result [fconfigure $outSide -checksum] + chan pop $outSide + $strm put -dictionary $spdyDict [read $inSide] + lappend result [string length $spdyHeaders] [string length [$strm get]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {3064818174 358 358} +test zlib-8.10 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -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 + throw UNREACHABLE "should be unreachable" + } err opt + list [string length [zlib deflate $spdyHeaders]] \ + [string length $compressed] \ + $err [dict get $opt -errorcode] +} -cleanup { + catch {close $outSide} + catch {close $inSide} +} -result {254 212 {data error} {TCL ZLIB DATA}} +test zlib-8.11 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream inflate] +} -constraints zlib -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 + $strm put -dictionary $spdyDict [read $inSide] + list [string length $spdyHeaders] [string length [$strm get]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358} +test zlib-8.12 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream compress] +} -constraints zlib -body { + $strm put -dictionary $spdyDict -finalize $spdyHeaders + zlib push decompress $inSide + fconfigure $outSide -blocking 0 -translation binary + fconfigure $inSide -translation binary -dictionary $spdyDict + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] \ + [fconfigure $inSide -checksum] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358 3064818174} +test zlib-8.13 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream compress] +} -constraints zlib -body { + $strm put -dictionary $spdyDict -finalize $spdyHeaders + zlib push decompress $inSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary + fconfigure $inSide -translation binary + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] \ + [fconfigure $inSide -checksum] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358 3064818174} +test zlib-8.14 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream deflate] +} -constraints zlib -body { + $strm put -finalize -dictionary $spdyDict $spdyHeaders + zlib push inflate $inSide + fconfigure $outSide -blocking 0 -buffering none -translation binary + fconfigure $inSide -translation binary -dictionary $spdyDict + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358} +test zlib-8.15 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream deflate] +} -constraints zlib -body { + $strm put -finalize -dictionary $spdyDict $spdyHeaders + zlib push inflate $inSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -buffering none -translation binary + fconfigure $inSide -translation binary + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] +} -cleanup { + catch {close $outSide} + 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] @@ -663,6 +855,20 @@ test zlib-11.2 "Bug #3390073: mis-appled gzip filtering" -setup { } -cleanup { removeFile $file } -result {1000 /foo/bar 0} +test zlib-11.3 {Bug 3595576 variant} -setup { + set file [makeFile {} test.input] +} -constraints zlib -body { + set f [open $file wb] + puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \ + [string repeat "hello" 1000] + close $f + set f [open $file rb] + set d [read $f] + close $f + zlib gunzip $d -header noSuchNs::foo +} -cleanup { + removeFile $file +} -returnCodes error -result {can't set "noSuchNs::foo": parent namespace doesn't exist} ::tcltest::cleanupTests return |