summaryrefslogtreecommitdiffstats
path: root/tests/cmdMZ.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/cmdMZ.test')
-rw-r--r--tests/cmdMZ.test291
1 files changed, 145 insertions, 146 deletions
diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test
index 7fe4fda..2d68138 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -1,15 +1,15 @@
# 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.
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
@@ -24,49 +24,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 {}
@@ -79,24 +94,25 @@ 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*}
+ return -code err
+} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
test cmdMZ-return-1.2 {return checks for bad option values} -body {
return -code 0x100000000
-} -returnCodes error -match glob -result {bad completion code*}
+} -returnCodes error -match glob -result {bad completion code "0x100000000": must be ok, error, return, break, continue*, or an integer}
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
}
@@ -131,11 +147,11 @@ test cmdMZ-return-2.8 {return option handling} -body {
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} {
+test cmdMZ-return-2.10 {return option handling} -body {
list [catch {return -level 0 -code error} -> foo] [dictSort $foo]
-} {1 {-code 1 -errorcode NONE -errorinfo {
+} -match glob -result {1 {-code 1 -errorcode NONE -errorinfo {
while executing
-"return -level 0 -code error"} -errorline 1 -level 0}}
+"return -level 0 -code error"} -errorline 1 -errorstack * -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}}
@@ -143,72 +159,66 @@ 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*}
+ return -level 0 -code error -options {-code err}
+} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer}
test cmdMZ-return-2.14 {return option handling} -body {
return -level 0 -code error -options {-code foo -options {-code break}}
} -returnCodes break -result {}
-
-test cmdMZ-return-2.15 {return opton handling} -setup {
- proc p {} {
- return -code error -errorcode {a b} c
- }
- } -body {
- list [catch p result] $result $::errorCode
- } -cleanup {
- rename p {}
- } -result {1 c {a b}}
-
-test cmdMZ-return-2.16 {return opton handling} -setup {
- proc p {} {
- return -code error -errorcode [list a b] c
- }
- } -body {
- list [catch p result] $result $::errorCode
- } -cleanup {
- rename p {}
- } -result {1 c {a b}}
-
-test cmdMZ-return-2.17 {return opton handling} -setup {
- proc p {} {
- return -code error -errorcode a\ b c
- }
- } -body {
- list [catch p result] $result $::errorCode
- } -cleanup {
- rename p {}
- } -result {1 c {a b}}
-
+test cmdMZ-return-2.15 {return opton handling} {
+ list [catch {
+ apply {{} {
+ return -code error -errorcode {a b} c
+ }}
+ } result] $result $::errorCode
+} {1 c {a b}}
+test cmdMZ-return-2.16 {return opton handling} {
+ list [catch {
+ apply {{} {
+ return -code error -errorcode [list a b] c
+ }}
+ } result] $result $::errorCode
+} {1 c {a b}}
+test cmdMZ-return-2.17 {return opton handling} {
+ list [catch {
+ apply {{} {
+ return -code error -errorcode a\ b c
+ }}
+ } result] $result $::errorCode
+} {1 c {a b}}
+test cmdMZ-return-2.18 {return option handling} {
+ list [catch {
+ return -code error -errorstack [list CALL a CALL b] yo
+ } -> foo] [dictSort $foo] [info errorstack]
+} {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}}
# Check that the result of a [return -options $opts $result] is
-# 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.12.1 {return -code error -errorinfo foo -errorcode bar -errorline 10 -errorstack baz}
+ 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
@@ -218,58 +228,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 {} {}}
@@ -292,23 +288,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}
@@ -321,21 +316,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
@@ -348,9 +343,13 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
"time {error foo}"}}
# The tests for Tcl_WhileObjCmd are in while.test
-
+
# cleanup
cleanupTests
}
namespace delete ::tcl::test::cmdMZ
return
+
+# Local Variables:
+# mode: tcl
+# End: