Use the powers of tcltest2 for good! Also add basic testing of disassmbler

(though not of its output format).

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: