diff options
Diffstat (limited to 'tests/cmdMZ.test')
| -rw-r--r-- | tests/cmdMZ.test | 269 |
1 files changed, 134 insertions, 135 deletions
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 85b7bde..ae96301 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -1,17 +1,17 @@ # The tests in this file cover the procedures in tclCmdMZ.c. # -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdMZ.test,v 1.25 2006/10/09 19:15:44 msofer Exp $ +# RCS: @(#) $Id: cmdMZ.test,v 1.26 2008/09/10 13:50:05 dkf Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -26,49 +26,64 @@ namespace eval ::tcl::test::cmdMZ { namespace import ::tcltest::temporaryDirectory namespace import ::tcltest::test + proc ListGlobMatch {expected actual} { + if {[llength $expected] != [llength $actual]} { + return 0 + } + foreach e $expected a $actual { + if {![string match $e $a]} { + return 0 + } + } + return 1 + } + customMatch listGlob [namespace which ListGlobMatch] + # Tcl_PwdObjCmd -test cmdMZ-1.1 {Tcl_PwdObjCmd} { - list [catch {pwd a} msg] $msg -} {1 {wrong # args: should be "pwd"}} +test cmdMZ-1.1 {Tcl_PwdObjCmd} -returnCodes error -body { + pwd a +} -result {wrong # args: should be "pwd"} test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} { catch pwd } 0 -test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} { - expr [string length pwd]>0 -} 1 -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. +test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} -body { + pwd +} -match glob -result {?*} +test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} -setup { + set cwd [pwd] set foodir [file join [temporaryDirectory] foo] file delete -force $foodir file mkdir $foodir - set cwd [pwd] cd $foodir +} -constraints {unix nonPortable} -body { + # 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. file attr . -permissions 000 - set result [list [catch {pwd} msg] $msg] + pwd +} -returnCodes error -cleanup { cd $cwd file delete -force $foodir - set result -} {1 {error getting working directory name: permission denied}} +} -result {error getting working directory name: permission denied} # The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test # Tcl_RenameObjCmd -test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} { - 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 -} {1 {wrong # args: should be "rename oldName newName"} NONE} -test cmdMZ-2.3 {Tcl_RenameObjCmd: success} { +test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} -returnCodes error -body { + rename r1 +} -result {wrong # args: should be "rename oldName newName"} +test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} -returnCodes error -body { + rename r1 r2 r3 +} -result {wrong # args: should be "rename oldName newName"} +test cmdMZ-2.3 {Tcl_RenameObjCmd: success} -setup { catch {rename r2 {}} +} -body { proc r1 {} {return "r1"} rename r1 r2 r2 -} {r1} +} -result {r1} test cmdMZ-2.4 {Tcl_RenameObjCmd: success} { proc r1 {} {return "r1"} rename r1 {} @@ -88,17 +103,18 @@ test cmdMZ-return-1.2 {return checks for bad option values} -body { } -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:*} +} -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:*} +} -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:*} +} -returnCodes error -match glob -result {bad -level value: *} proc dictSort {d} { + set result {} foreach k [lsort [dict keys $d]] { - lappend result $k [dict get $d $k] + dict set result $k [dict get $d $k] } return $result } @@ -150,67 +166,61 @@ test cmdMZ-return-2.13 {return option handling} -body { test cmdMZ-return-2.14 {return option handling} -body { return -level 0 -code error -options {-code foo -options {-code break}} } -returnCodes break -result {} - test cmdMZ-return-2.15 {return opton handling} -setup { - proc p {} { - return -code error -errorcode {a b} c - } - } -body { - list [catch p result] $result $::errorCode - } -cleanup { - rename p {} - } -result {1 c {a b}} - + 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}} - + 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}} - + 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} +# indistinguishable from that of the originally caught script, no matter what +# the script is/does. (TIP 90) +foreach {testid script} { + cmdMZ-return-3.0 {} + cmdMZ-return-3.1 {format x} + cmdMZ-return-3.2 {set} + cmdMZ-return-3.3 {set a 1} + cmdMZ-return-3.4 {error} + cmdMZ-return-3.5 {error foo} + cmdMZ-return-3.6 {error foo bar} + cmdMZ-return-3.7 {error foo bar baz} + cmdMZ-return-3.8 {return -level 0} + cmdMZ-return-3.9 {return -code error} + cmdMZ-return-3.10 {return -code error -errorinfo foo} + cmdMZ-return-3.11 {return -code error -errorinfo foo -errorcode bar} + cmdMZ-return-3.12 {return -code error -errorinfo foo -errorcode bar -errorline 10} + cmdMZ-return-3.13 {return -options {x y z 2}} + cmdMZ-return-3.14 {return -level 3 -code break sdf} } { - test cmdMZ-return-3.$i "check that return after a catch is same:\n$script" { + test $testid "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 @@ -220,58 +230,44 @@ foreach script { test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { unixOrPc -} -body { - list [catch {source} msg] $msg -} -match glob -result {1 {wrong # args: should be "source*fileName"}} +} -returnCodes error -body { + source +} -match glob -result {wrong # args: should be "source*fileName"} test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { unixOrPc -} -body { - list [catch {source a b} msg] $msg -} -match glob -result {1 {wrong # args: should be "source*fileName"}} - -proc ListGlobMatch {expected actual} { - if {[llength $expected] != [llength $actual]} { - return 0 - } - foreach e $expected a $actual { - if {![string match $e $a]} { - return 0 - } - } - return 1 -} -customMatch listGlob [namespace which ListGlobMatch] - +} -returnCodes error -body { + source a b +} -match glob -result {wrong # args: should be "source*fileName"} 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] - set result [list [catch {source $file} msg] $msg $::errorInfo] + list [catch {source $file} msg] $msg $::errorInfo +} -cleanup { removeFile source.file - set result } -match listGlob -result {1 {error in sourced file} {error in sourced file while executing "error "error in sourced file"" (file "*" line 3) invoked from within "source $file"}} -test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} { - set file [makeFile {list result} source.file] - set result [source $file] +test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} -body { + set file [makeFile {list ok} source.file] + source $file +} -cleanup { removeFile source.file - set result -} result +} -result ok # Tcl_SplitObjCmd -test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} { - 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 -} {1 {wrong # args: should be "split string ?splitChars?"} NONE} +test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} -returnCodes error -body { + split +} -result {wrong # args: should be "split string ?splitChars?"} +test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} -returnCodes error -body { + split a b c +} -result {wrong # args: should be "split string ?splitChars?"} test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} { split "a\n b\t\r c\n " } {a {} b {} {} c {} {}} @@ -294,23 +290,22 @@ test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} { split { } } {{} {} {} {}} test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} { - proc foo {} { + apply {{} { set x {} foreach f [split {]\n} {}] { append x $f } - return $x - } - foo + return $x + }} } {]\n} test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} { - proc foo {} { + apply {{} { set x ab\000c set y [split $x {}] - return $y - } - foo -} "a b \000 c" + binary scan $y c* z + return $z + }} +} {97 32 98 32 0 32 99} test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} { split "a0ab1b2bbb3\000c4" ab\000c } {{} 0 {} 1 2 {} {} 3 {} 4} @@ -323,21 +318,21 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { # The tests for Tcl_SubstObjCmd are in subst.test # The tests for Tcl_SwitchObjCmd are in switch.test -test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} { - list [catch {time} msg] $msg -} {1 {wrong # args: should be "time command ?count?"}} -test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} { - list [catch {time a b c} msg] $msg -} {1 {wrong # args: should be "time command ?count?"}} -test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} { - list [catch {time a b} msg] $msg -} {1 {expected integer but got "b"}} +test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body { + time +} -returnCodes error -result {wrong # args: should be "time command ?count?"} +test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body { + time a b c +} -returnCodes error -result {wrong # args: should be "time command ?count?"} +test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body { + time a b +} -returnCodes error -result {expected integer but got "b"} test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} { time bogusCmd -12456 } {0 microseconds per iteration} -test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} { - regexp {^\d+ microseconds per iteration} [time {format 1}] -} 1 +test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body { + time {format 1} +} -match regexp -result {^\d+ microseconds per iteration} test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} { expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]} } 1 @@ -356,3 +351,7 @@ cleanupTests } namespace delete ::tcl::test::cmdMZ return + +# Local Variables: +# mode: tcl +# End: |