diff options
Diffstat (limited to 'tests/cmdMZ.test')
| -rw-r--r-- | tests/cmdMZ.test | 206 |
1 files changed, 175 insertions, 31 deletions
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index b4e91c6..7fe4fda 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -11,11 +11,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} { - package require tcltest 2.1 - namespace import -force ::tcltest::* +if {[catch {package require tcltest 2.1}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.1 required." + return } +namespace eval ::tcl::test::cmdMZ { + namespace import ::tcltest::cleanupTests + namespace import ::tcltest::customMatch + namespace import ::tcltest::makeFile + namespace import ::tcltest::removeFile + namespace import ::tcltest::temporaryDirectory + namespace import ::tcltest::test + # Tcl_PwdObjCmd test cmdMZ-1.1 {Tcl_PwdObjCmd} { @@ -27,7 +35,7 @@ test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} { test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} { expr [string length pwd]>0 } 1 -test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unixOnly nonPortable} { +test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unix nonPortable} { # This test fails on various unix platforms (eg Linux) where # permissions caching causes this to fail. The caching is strictly # incorrect, but we have no control over that. @@ -48,10 +56,10 @@ test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unixOnly nonPortable} { # Tcl_RenameObjCmd test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} { - list [catch {rename r1} msg] $msg $errorCode + list [catch {rename r1} msg] $msg $::errorCode } {1 {wrong # args: should be "rename oldName newName"} NONE} test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} { - list [catch {rename r1 r2 r3} msg] $msg $errorCode + list [catch {rename r1 r2 r3} msg] $msg $::errorCode } {1 {wrong # args: should be "rename oldName newName"} NONE} test cmdMZ-2.3 {Tcl_RenameObjCmd: success} { catch {rename r2 {}} @@ -65,47 +73,182 @@ test cmdMZ-2.4 {Tcl_RenameObjCmd: success} { list [catch {r1} msg] $msg } {1 {invalid command name "r1"}} -# The tests for Tcl_ReturnObjCmd are in proc-old.test +# Some tests for Tcl_ReturnObjCmd are in proc-old.test + +test cmdMZ-return-1.0 {return checks for bad option values} -body { + return -options foo +} -returnCodes error -match glob -result {bad -options value:*} +test cmdMZ-return-1.1 {return checks for bad option values} -body { + return -code foo +} -returnCodes error -match glob -result {bad completion code*} +test cmdMZ-return-1.2 {return checks for bad option values} -body { + return -code 0x100000000 +} -returnCodes error -match glob -result {bad completion code*} +test cmdMZ-return-1.3 {return checks for bad option values} -body { + return -level foo +} -returnCodes error -match glob -result {bad -level value:*} +test cmdMZ-return-1.4 {return checks for bad option values} -body { + return -level -1 +} -returnCodes error -match glob -result {bad -level value:*} +test cmdMZ-return-1.5 {return checks for bad option values} -body { + return -level 3.1415926 +} -returnCodes error -match glob -result {bad -level value:*} + +proc dictSort {d} { + foreach k [lsort [dict keys $d]] { + lappend result $k [dict get $d $k] + } + return $result +} + +test cmdMZ-return-2.0 {return option handling} { + list [catch return -> foo] [dictSort $foo] +} {2 {-code 0 -level 1}} +test cmdMZ-return-2.1 {return option handling} { + list [catch {return -bar soom} -> foo] [dictSort $foo] +} {2 {-bar soom -code 0 -level 1}} +test cmdMZ-return-2.2 {return option handling} { + list [catch {return -code return} -> foo] [dictSort $foo] +} {2 {-code 0 -level 2}} +test cmdMZ-return-2.3 {return option handling} { + list [catch {return -code return -level 10} -> foo] [dictSort $foo] +} {2 {-code 0 -level 11}} +test cmdMZ-return-2.4 {return option handling} -body { + return -level 0 -code error +} -returnCodes error -result {} +test cmdMZ-return-2.5 {return option handling} -body { + return -level 0 -code return +} -returnCodes return -result {} +test cmdMZ-return-2.6 {return option handling} -body { + return -level 0 -code break +} -returnCodes break -result {} +test cmdMZ-return-2.7 {return option handling} -body { + return -level 0 -code continue +} -returnCodes continue -result {} +test cmdMZ-return-2.8 {return option handling} -body { + return -level 0 -code -1 +} -returnCodes -1 -result {} +test cmdMZ-return-2.9 {return option handling} -body { + return -level 0 -code 10 +} -returnCodes 10 -result {} +test cmdMZ-return-2.10 {return option handling} { + list [catch {return -level 0 -code error} -> foo] [dictSort $foo] +} {1 {-code 1 -errorcode NONE -errorinfo { + while executing +"return -level 0 -code error"} -errorline 1 -level 0}} +test cmdMZ-return-2.11 {return option handling} { + list [catch {return -level 0 -code break} -> foo] [dictSort $foo] +} {3 {-code 3 -level 0}} +test cmdMZ-return-2.12 {return option handling} -body { + return -level 0 -code error -options {-code ok} +} -returnCodes ok -result {} +test cmdMZ-return-2.13 {return option handling} -body { + return -level 0 -code error -options {-code foo} +} -returnCodes error -match glob -result {bad completion code*} +test cmdMZ-return-2.14 {return option handling} -body { + return -level 0 -code error -options {-code foo -options {-code break}} +} -returnCodes break -result {} + +test cmdMZ-return-2.15 {return opton handling} -setup { + proc p {} { + return -code error -errorcode {a b} c + } + } -body { + list [catch p result] $result $::errorCode + } -cleanup { + rename p {} + } -result {1 c {a b}} + +test cmdMZ-return-2.16 {return opton handling} -setup { + proc p {} { + return -code error -errorcode [list a b] c + } + } -body { + list [catch p result] $result $::errorCode + } -cleanup { + rename p {} + } -result {1 c {a b}} + +test cmdMZ-return-2.17 {return opton handling} -setup { + proc p {} { + return -code error -errorcode a\ b c + } + } -body { + list [catch p result] $result $::errorCode + } -cleanup { + rename p {} + } -result {1 c {a b}} + + +# Check that the result of a [return -options $opts $result] is +# indistinguishable from that of the originally caught script, no +# matter what the script is/does. (TIP 90) +set i 0 +foreach script { + {} + {format x} + {set} + {set a 1} + {error} + {error foo} + {error foo bar} + {error foo bar baz} + {return -level 0} + {return -code error} + {return -code error -errorinfo foo} + {return -code error -errorinfo foo -errorcode bar} + {return -code error -errorinfo foo -errorcode bar -errorline 10} + {return -options {x y z 2}} + {return -level 3 -code break sdf} +} { + test cmdMZ-return-3.$i "check that return after a catch is same:\n$script" { + set one [list [catch $script foo bar] $foo [dictSort $bar] \ + $::errorCode $::errorInfo] + set two [list [catch {return -options $bar $foo} foo2 bar2] \ + $foo2 [dictSort $bar2] $::errorCode $::errorInfo] + string equal $one $two + } 1 + incr i +} + # The tests for Tcl_ScanObjCmd are in scan.test # Tcl_SourceObjCmd +# More tests of Tcl_SourceObjCmd are in source.test -test cmdMZ-3.1 {Tcl_SourceObjCmd: error conditions} {macOnly} { - list [catch {source} msg] $msg -} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -test cmdMZ-3.2 {Tcl_SourceObjCmd: error conditions} {macOnly} { - list [catch {source a b} msg] $msg -} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} { +test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { + unixOrPc +} -body { list [catch {source} msg] $msg -} {1 {wrong # args: should be "source fileName"}} -test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} { +} -match glob -result {1 {wrong # args: should be "source*fileName"}} +test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { + unixOrPc +} -body { list [catch {source a b} msg] $msg -} {1 {wrong # args: should be "source fileName"}} +} -match glob -result {1 {wrong # args: should be "source*fileName"}} proc ListGlobMatch {expected actual} { if {[llength $expected] != [llength $actual]} { - return 0 + return 0 } foreach e $expected a $actual { - if {![string match $e $a]} { - return 0 - } + if {![string match $e $a]} { + return 0 + } } return 1 } -customMatch listGlob ListGlobMatch +customMatch listGlob [namespace which ListGlobMatch] -test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -setup { +test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { set file [makeFile { set x 146 error "error in sourced file" set y $x } source.file] -} -body { - list [catch {source $file} msg] $msg $errorInfo -} -cleanup { + set result [list [catch {source $file} msg] $msg $::errorInfo] removeFile source.file + set result } -match listGlob -result {1 {error in sourced file} {error in sourced file while executing "error "error in sourced file"" @@ -122,10 +265,10 @@ test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} { # Tcl_SplitObjCmd test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} { - list [catch split msg] $msg $errorCode + list [catch split msg] $msg $::errorCode } {1 {wrong # args: should be "split string ?splitChars?"} NONE} test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} { - list [catch {split a b c} msg] $msg $errorCode + list [catch {split a b c} msg] $msg $::errorCode } {1 {wrong # args: should be "split string ?splitChars?"} NONE} test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} { split "a\n b\t\r c\n " @@ -138,7 +281,7 @@ test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} { } {1 2 3 4 5} test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} { split "a\}b\[c\{\]\$" -} "a\\}b\\\[c\\{\\\]\\\$" +} "a\\\}b\\\[c\\\{\\\]\\\$" test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} { split {} {} } {} @@ -204,9 +347,10 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { invoked from within "time {error foo}"}} -# The tests for Tcl_TraceObjCmd and TraceVarProc are in trace.test # The tests for Tcl_WhileObjCmd are in while.test # cleanup -::tcltest::cleanupTests +cleanupTests +} +namespace delete ::tcl::test::cmdMZ return |