Clean up of tests and conversion to tcltest 2. Target has been to get init and

cleanup code out of the test body and into the -setup/-cleanup stanzas.

1 files changed, 172 insertions, 185 deletions

diff --git a/tests/proc.test b/tests/proc.test
index 789c671..ba0c20d 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -1,40 +1,36 @@
-# This file contains tests for the tclProc.c source file. Tests appear in
-# the same order as the C code that they test. The set of tests is
-# currently incomplete since it includes only new tests, in particular
-# tests for code changed for the addition of Tcl namespaces. Other
-# procedure-related tests appear in other test files such as proc-old.test.
+# This file contains tests for the tclProc.c source file. Tests appear in the
+# same order as the C code that they test. The set of tests is currently
+# incomplete since it includes only new tests, in particular tests for code
+# changed for the addition of Tcl namespaces. Other procedure-related tests
+# appear in other test files such as proc-old.test.
 #
-# Sourcing this file into Tcl runs the tests and generates output for
-# errors.  No output means no errors were found.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
 #
 # Copyright (c) 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.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: proc.test,v 1.21 2009/10/29 17:21:48 dgp Exp $
+# RCS: @(#) $Id: proc.test,v 1.22 2011/01/01 15:14:43 dkf Exp $
 
-if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
+if {"::tcltest" ni [namespace children]} {
+    package require tcltest 2
     namespace import -force ::tcltest::*
 }
 
-if {[catch {package require procbodytest}]} {
-    testConstraint procbodytest 0
-} else {
-    testConstraint procbodytest 1
-}
-
-testConstraint memory     [llength [info commands memory]]
+testConstraint procbodytest [expr {![catch {package require procbodytest}]}]
+testConstraint memory	    [llength [info commands memory]]
 
 catch {namespace delete {*}[namespace children :: test_ns_*]}
 catch {rename p ""}
 catch {rename {} ""}
 catch {unset msg}
-
-test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} {
+
+test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
     namespace eval test_ns_1 {
         namespace eval baz {}
     }
@@ -44,23 +40,26 @@ test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any}
     list [test_ns_1::baz::p] \
          [namespace eval test_ns_1 {baz::p}] \
          [info commands test_ns_1::baz::*]
-} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p}
-test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} {
+} -result {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p}
+test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
-    list [catch {proc test_ns_1::baz::p {} {}} msg] $msg
-} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}}
-test proc-1.3 {Tcl_ProcObjCmd, empty proc name} {
+} -returnCodes error -body {
+    proc test_ns_1::baz::p {} {}
+} -result {can't create procedure "test_ns_1::baz::p": unknown namespace}
+test proc-1.3 {Tcl_ProcObjCmd, empty proc name} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
     proc :: {} {
         return "empty called"
     }
     list [::] \
          [info body {}]
-} {{empty called} {
+} -result {{empty called} {
         return "empty called"
     }}
-test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {
+test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
     namespace eval test_ns_1 {
         namespace eval baz {
             proc p {} {
@@ -70,9 +69,10 @@ test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {
     }
     list [test_ns_1::baz::p] \
          [info commands test_ns_1::baz::*]
-} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p}
-test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} {
+} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p}
+test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
     namespace eval test_ns_1::baz {}
     namespace eval test_ns_1 {
         proc baz::p {} {
@@ -82,9 +82,10 @@ test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace
     list [test_ns_1::baz::p] \
          [info commands test_ns_1::baz::*] \
          [namespace eval test_ns_1::baz {namespace which p}]
-} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p}
-test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} {
+} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p}
+test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
     namespace eval test_ns_1 {
         proc q: {} {return "q:"}
         proc value:at: {} {return "value:at:"}
@@ -96,88 +97,97 @@ test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or e
          [lsort [info commands test_ns_1::*]] \
          [namespace eval test_ns_1 {namespace which q:}] \
          [namespace eval test_ns_1 {namespace which value:at:}]
-} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:}
-test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} {
+} -result {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:}
+test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup {
     catch {rename p ""}
-    list [catch {proc p {a(1) a(2)} { 
-            set z [expr $a(1)+$a(2)]
-            puts "$z=z, $a(1)=$a(1)"
-        }} msg] $msg
-} {1 {formal parameter "a(1)" is an array element}}
-test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} {
+} -returnCodes error -body {
+    proc p {a(1) a(2)} { 
+	set z [expr $a(1)+$a(2)]
+	puts "$z=z, $a(1)=$a(1)"
+    }
+} -result {formal parameter "a(1)" is an array element}
+test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup {
     catch {rename p ""}
-    list [catch {proc p {b:a b::a} { 
-    }} msg] $msg
-} {1 {formal parameter "b::a" is not a simple name}}
+} -body {
+    proc p {b:a b::a} { 
+    }
+} -returnCodes error -result {formal parameter "b::a" is not a simple name}
 
-test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} {
+test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
     catch {rename p ""}
+} -body {
     proc p {} {return "p in [namespace current]"}
     info body p
-} {return "p in [namespace current]"}
-test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} {
+} -result {return "p in [namespace current]"}
+test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
     namespace eval test_ns_1 {
         namespace eval baz {
             proc p {} {return "p in [namespace current]"}
         }
     }
     namespace eval test_ns_1::baz {info body p}
-} {return "p in [namespace current]"}
-test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} {
+} -result {return "p in [namespace current]"}
+test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
     namespace eval test_ns_1::baz {}
     namespace eval test_ns_1 {
         proc baz::p {} {return "p in [namespace current]"}
     }
     namespace eval test_ns_1 {info body baz::p}
-} {return "p in [namespace current]"}
-test proc-2.4 {TclFindProc, global proc and executing in namespace} {
+} -result {return "p in [namespace current]"}
+test proc-2.4 {TclFindProc, global proc and executing in namespace} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
     catch {rename p ""}
+} -body {
     proc p {} {return "global p"}
     namespace eval test_ns_1::baz {info body p}
-} {return "global p"}
+} -result {return "global p"}
 
-test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} {
+test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
     proc p {} {return "p in [namespace current]"}
     p
-} {p in ::}
-test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} {
+} -result {p in ::}
+test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
     namespace eval test_ns_1::baz {
         proc p {} {return "p in [namespace current]"}
         p
     }
-} {p in ::test_ns_1::baz}
-test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} {
+} -result {p in ::test_ns_1::baz}
+test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
     catch {rename p ""}
+} -body {
     proc p {} {return "p in [namespace current]"}
     namespace eval test_ns_1::baz {
         p
     }
-} {p in ::}
-test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {
+} -result {p in ::}
+test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
     catch {rename p ""}
+} -body {
     namespace eval test_ns_1::baz {
         proc p {} {return "p in [namespace current]"}
         rename ::test_ns_1::baz::p ::p
         list [p] [namespace which p]
     }
-} {{p in ::} ::p}
-test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
+} -result {{p in ::} ::p}
+test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} -body {
     proc p {x} {info commands 3m}
-    list [catch {p} msg] $msg
-} {1 {wrong # args: should be "p x"}}
-
-test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} {
+    p
+} -returnCodes error -result {wrong # args: should be "p x"}
+test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} -body {
     proc {a b  c} {x} {info commands 3m}
-    list [catch {{a b  c}} msg] $msg
-} {1 {wrong # args: should be "{a b  c} x"}}
+    {a b  c}
+} -returnCodes error -result {wrong # args: should be "{a b  c} x"}
 
 catch {namespace delete {*}[namespace children :: test_ns_*]}
 catch {rename p ""}
@@ -189,116 +199,95 @@ catch {rename p ""}
 catch {rename t ""}
 
 # Note that the test require that procedures whose body is used to create
-# procbody objects must be executed before the procbodytest::proc command
-# is executed, so that the Proc struct is populated correctly (CompiledLocals
-# are added at compile time).
+# procbody objects must be executed before the procbodytest::proc command is
+# executed, so that the Proc struct is populated correctly (CompiledLocals are
+# added at compile time).
 
-test proc-4.1 {TclCreateProc, procbody obj} procbodytest {
-    catch {
-	proc p x {return "$x:$x"}
-	set rv [p P]
-	procbodytest::proc t x p
-	lappend rv [t T]
-	set rv
-    } result
+test proc-4.1 {TclCreateProc, procbody obj} -constraints procbodytest -body {
+    proc p x {return "$x:$x"}
+    set rv [p P]
+    procbodytest::proc t x p
+    lappend rv [t T]
+} -cleanup {
     catch {rename p ""}
     catch {rename t ""}
-    set result
-} {P:P T:T}
-test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} procbodytest {
-    catch {
-	proc p x {
-	    set y [string tolower $x]
-	    return "$x:$y"
-	}
-	set rv [p P]
-	procbodytest::proc t x p
-	lappend rv [t T]
-	set rv
-    } result
+} -result {P:P T:T}
+test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} -body {
+    proc p x {
+	set y [string tolower $x]
+	return "$x:$y"
+    }
+    set rv [p P]
+    procbodytest::proc t x p
+    lappend rv [t T]
+} -constraints procbodytest -cleanup {
     catch {rename p ""}
     catch {rename t ""}
-    set result
-} {P:p T:t}
-test proc-4.3 {TclCreateProc, procbody obj, too many args} procbodytest {
-    catch {
-	proc p x {
-	    set y [string tolower $x]
-	    return "$x:$y"
-	}
-	set rv [p P]
-	procbodytest::proc t {x x1 x2} p
-	lappend rv [t T]
-	set rv
-    } result
+} -result {P:p T:t}
+test proc-4.3 {TclCreateProc, procbody obj, too many args} -body {
+    proc p x {
+	set y [string tolower $x]
+	return "$x:$y"
+    }
+    set rv [p P]
+    procbodytest::proc t {x x1 x2} p
+    lappend rv [t T]
+} -constraints procbodytest -returnCodes error -cleanup {
     catch {rename p ""}
     catch {rename t ""}
-    set result
-} {procedure "t": arg list contains 3 entries, precompiled header expects 1}
-test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} procbodytest {
-    catch {
-	proc p {x y z} {
-	    set v [join [list $x $y $z]]
-	    set w [string tolower $v]
-	    return "$v:$w"
-	}
-	set rv [p P Q R]
-	procbodytest::proc t {x x1 z} p
-	lappend rv [t S T U]
-	set rv
-    } result
+} -result {procedure "t": arg list contains 3 entries, precompiled header expects 1}
+test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} -body {
+    proc p {x y z} {
+	set v [join [list $x $y $z]]
+	set w [string tolower $v]
+	return "$v:$w"
+    }
+    set rv [p P Q R]
+    procbodytest::proc t {x x1 z} p
+    lappend rv [t S T U]
+} -constraints procbodytest -returnCodes error -cleanup {
     catch {rename p ""}
     catch {rename t ""}
-    set result
-} {procedure "t": formal parameter 1 is inconsistent with precompiled body}
-test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} procbodytest {
-    catch {
-	proc p {x y {z Z}} {
-	    set v [join [list $x $y $z]]
-	    set w [string tolower $v]
-	    return "$v:$w"
-	}
-	set rv [p P Q R]
-	procbodytest::proc t {x y z} p
-	lappend rv [t S T U]
-	set rv
-    } result
+} -result {procedure "t": formal parameter 1 is inconsistent with precompiled body}
+test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body {
+    proc p {x y {z Z}} {
+	set v [join [list $x $y $z]]
+	set w [string tolower $v]
+	return "$v:$w"
+    }
+    set rv [p P Q R]
+    procbodytest::proc t {x y z} p
+    lappend rv [t S T U]
+} -constraints procbodytest -returnCodes error -cleanup {
     catch {rename p ""}
     catch {rename t ""}
-    set result
-} {procedure "t": formal parameter 2 is inconsistent with precompiled body}
-test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} procbodytest {
-    catch {
-	proc p {x y z} {
-	    set v [join [list $x $y $z]]
-	    set w [string tolower $v]
-	    return "$v:$w"
-	}
-	set rv [p P Q R]
-	procbodytest::proc t {x y {z Z}} p
-	lappend rv [t S T U]
-	set rv
-    } result
+} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body}
+test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body {
+    proc p {x y z} {
+	set v [join [list $x $y $z]]
+	set w [string tolower $v]
+	return "$v:$w"
+    }
+    set rv [p P Q R]
+    procbodytest::proc t {x y {z Z}} p
+    lappend rv [t S T U]
+} -returnCodes error -constraints procbodytest -cleanup {
     catch {rename p ""}
     catch {rename t ""}
-    set result
-} {procedure "t": formal parameter 2 is inconsistent with precompiled body}
-test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} procbodytest {
-    catch {
-	proc p {x y {z Z}} {
-	    set v [join [list $x $y $z]]
-	    set w [string tolower $v]
-	    return "$v:$w"
-	}
-	set rv [p P Q R]
-	procbodytest::proc t {x y {z ZZ}} p
-	lappend rv [t S T U]
-	set rv
-    } result
+} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body}
+test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -body {
+    proc p {x y {z Z}} {
+	set v [join [list $x $y $z]]
+	set w [string tolower $v]
+	return "$v:$w"
+    }
+    set rv [p P Q R]
+    procbodytest::proc t {x y {z ZZ}} p
+    lappend rv [t S T U]
+} -constraints procbodytest -returnCodes error -cleanup {
     catch {rename p ""}
     catch {rename t ""}
-    set result
-} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
+} -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
 test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup {
     proc getbytes {} {
 	set lines [split [memory info] "\n"]
@@ -310,12 +299,9 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set
     }
     px x
 } -constraints {procbodytest memory} -body {
-
     set end [getbytes]
     for {set i 0} {$i < 5} {incr i} {
-
 	procbodytest::proc tx x px
-
 	set tmp $end
 	set end [getbytes]
     }
@@ -325,7 +311,7 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set
     unset -nocomplain end i tmp leakedBytes
 } -result 0
 
-test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {
+test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body {
     proc p args {} ; # this will be bytecompiled into t
     proc t {} {
 	set res {}
@@ -336,20 +322,20 @@ test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {
 	p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello
 	set res
     }
-    set result [t]
+    t
+} -cleanup {
     catch {rename p ""}
     catch {rename t ""}
-    set result
-} {aba}    
+} -result {aba}    
 
-test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} {
+test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} -body {
     proc a {} {return -code -5}
     proc b {} a
-    set result [catch b]
+    catch b
+} -cleanup {
     rename a {}
     rename b {}
-    set result
-} -5
+} -result -5
 
 test proc-7.1 {Redefining a compiled cmd: Bug 729692} {
     proc bar args {}
@@ -359,19 +345,17 @@ test proc-7.1 {Redefining a compiled cmd: Bug 729692} {
     }
     foo
 } bar
-
-test proc-7.2 {Shadowing a compiled cmd: Bug 729692} {
+test proc-7.2 {Shadowing a compiled cmd: Bug 729692} -body {
     namespace eval ugly {}
     proc ugly::foo {} {
 	proc set args {return bar}
 	set x 1
     }
-    set res [list [catch {ugly::foo} msg] $msg]
+    ugly::foo
+} -cleanup {
     namespace delete ugly
-    set res
-} {0 bar}
-
-test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} {
+} -result bar
+test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body {
     namespace eval ugly {}
     proc ugly::foo {} {
 	set i 0
@@ -383,15 +367,18 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} {
 	}
 	return $i
     }
-    set res [list [catch {ugly::foo} msg] $msg]
+    ugly::foo
+} -cleanup {
     namespace delete ugly
-    set res
-} {0 4}
-
-
-
+} -result 4
+
 # cleanup
 catch {rename p ""}
 catch {rename t ""}
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End: