summaryrefslogtreecommitdiffstats
path: root/tests/proc.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/proc.test')
-rw-r--r--tests/proc.test133
1 files changed, 81 insertions, 52 deletions
diff --git a/tests/proc.test b/tests/proc.test
index 8974663..c0f80e3 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -18,15 +18,21 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
namespace import -force ::tcltest::*
}
+if {[catch {package require procbodytest}]} {
+ testConstraint procbodytest 0
+} else {
+ testConstraint procbodytest 1
+}
+
testConstraint memory [llength [info commands memory]]
-catch {eval namespace delete [namespace children :: test_ns_*]}
+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} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {}
}
@@ -38,11 +44,11 @@ test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any}
[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} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ 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} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
proc :: {} {
return "empty called"
}
@@ -52,7 +58,7 @@ test proc-1.3 {Tcl_ProcObjCmd, empty proc name} {
return "empty called"
}}
test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {
@@ -64,7 +70,7 @@ test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {
[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} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {
@@ -76,7 +82,7 @@ test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace
[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} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc q: {} {return "q:"}
proc value:at: {} {return "value:at:"}
@@ -95,21 +101,21 @@ test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array e
set z [expr $a(1)+$a(2)]
puts "$z=z, $a(1)=$a(1)"
}} msg] $msg
-} {1 {procedure "p" has formal parameter "a(1)" that is an array element}}
+} {1 {formal parameter "a(1)" is an array element}}
test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} {
catch {rename p ""}
list [catch {proc p {b:a b::a} {
}} msg] $msg
-} {1 {procedure "p" has formal parameter "b::a" that is not a simple name}}
+} {1 {formal parameter "b::a" is not a simple name}}
test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
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} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {return "p in [namespace current]"}
@@ -118,7 +124,7 @@ test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} {
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} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {return "p in [namespace current]"}
@@ -126,26 +132,26 @@ test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} {
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} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {return "global p"}
namespace eval test_ns_1::baz {info body p}
} {return "global p"}
test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
proc p {} {return "p in [namespace current]"}
p
} {p in ::}
test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
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} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {return "p in [namespace current]"}
namespace eval test_ns_1::baz {
@@ -153,7 +159,7 @@ test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespa
}
} {p in ::}
test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
namespace eval test_ns_1::baz {
proc p {} {return "p in [namespace current]"}
@@ -176,19 +182,12 @@ test proc-3.7 {TclObjInterpProc, wrong num args, Bug 3366265} {
list [catch {{}} msg] $msg
} {1 {wrong # args: should be "{} x"}}
-catch {eval namespace delete [namespace children :: test_ns_*]}
+catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {rename {a b c} {}}
catch {unset msg}
-if {[catch {package require procbodytest}]} {
- puts "This application couldn't load the \"procbodytest\" package, so I"
- puts "can't test creation of procs whose bodies have type \"procbody\"."
- ::tcltest::cleanupTests
- return
-}
-
catch {rename p ""}
catch {rename t ""}
@@ -197,7 +196,7 @@ catch {rename t ""}
# is executed, so that the Proc struct is populated correctly (CompiledLocals
# are added at compile time).
-test proc-4.1 {TclCreateProc, procbody obj} {
+test proc-4.1 {TclCreateProc, procbody obj} procbodytest {
catch {
proc p x {return "$x:$x"}
set rv [p P]
@@ -209,8 +208,7 @@ test proc-4.1 {TclCreateProc, procbody obj} {
catch {rename t ""}
set result
} {P:P T:T}
-
-test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} {
+test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} procbodytest {
catch {
proc p x {
set y [string tolower $x]
@@ -225,8 +223,7 @@ test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} {
catch {rename t ""}
set result
} {P:p T:t}
-
-test proc-4.3 {TclCreateProc, procbody obj, too many args} {
+test proc-4.3 {TclCreateProc, procbody obj, too many args} procbodytest {
catch {
proc p x {
set y [string tolower $x]
@@ -241,8 +238,7 @@ test proc-4.3 {TclCreateProc, procbody obj, too many args} {
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} {
+test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} procbodytest {
catch {
proc p {x y z} {
set v [join [list $x $y $z]]
@@ -258,8 +254,7 @@ test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} {
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} {
+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]]
@@ -275,8 +270,7 @@ test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} {
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} {
+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]]
@@ -292,8 +286,7 @@ test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} {
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} {
+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]]
@@ -309,7 +302,6 @@ test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} {
catch {rename t ""}
set 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"]
@@ -320,7 +312,8 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set
return "$x:$y"
}
px x
-} -constraints memory -body {
+} -constraints {procbodytest memory} -body {
+
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
@@ -332,6 +325,7 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set
set leakedBytes [expr {$end - $tmp}]
} -cleanup {
rename getbytes {}
+ unset -nocomplain end i tmp leakedBytes
} -result 0
test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {
@@ -360,20 +354,55 @@ test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} {
set result
} -5
+test proc-7.1 {Redefining a compiled cmd: Bug 729692} {
+ proc bar args {}
+ proc foo {} {
+ proc bar args {return bar}
+ bar
+ }
+ foo
+} bar
+
+test proc-7.2 {Shadowing a compiled cmd: Bug 729692} {
+ namespace eval ugly {}
+ proc ugly::foo {} {
+ proc set args {return bar}
+ set x 1
+ }
+ set res [list [catch {ugly::foo} msg] $msg]
+ namespace delete ugly
+ set res
+} {0 bar}
+
+test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} {
+ namespace eval ugly {}
+ proc ugly::foo {} {
+ set i 0
+ while { 1 } {
+ if { [incr i] > 3 } {
+ proc continue {} {return -code break}
+ }
+ continue
+ }
+ return $i
+ }
+ set res [list [catch {ugly::foo} msg] $msg]
+ namespace delete ugly
+ set res
+} {0 4}
+
+test proc-7.4 {Proc struct outlives its interp: Bug 3532959} {
+ set lambda x
+ lappend lambda {set a 1}
+ interp create slave
+ slave eval [list apply $lambda foo]
+ interp delete slave
+ unset lambda
+} {}
+
+
# cleanup
catch {rename p ""}
catch {rename t ""}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-