1# This file contains tests for the tclProc.c source file. Tests appear in the 2# same order as the C code that they test. The set of tests is currently 3# incomplete since it includes only new tests, in particular tests for code 4# changed for the addition of Tcl namespaces. Other procedure-related tests 5# appear in other test files such as proc-old.test. 6# 7# Sourcing this file into Tcl runs the tests and generates output for errors. 8# No output means no errors were found. 9# 10# Copyright © 1997 Sun Microsystems, Inc. 11# Copyright © 1998-1999 Scriptics Corporation. 12# 13# See the file "license.terms" for information on usage and redistribution of 14# this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 16if {"::tcltest" ni [namespace children]} { 17 package require tcltest 2.5 18 namespace import -force ::tcltest::* 19} 20::tcltest::loadTestedCommands 21 22testConstraint tcl::test [expr {![catch {package require tcl::test}]}] 23testConstraint memory [llength [info commands memory]] 24 25catch {namespace delete {*}[namespace children :: test_ns_*]} 26catch {rename p ""} 27catch {rename {} ""} 28catch {unset msg} 29 30test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} -setup { 31 catch {namespace delete {*}[namespace children :: test_ns_*]} 32} -body { 33 namespace eval test_ns_1 { 34 namespace eval baz {} 35 } 36 proc test_ns_1::baz::p {} { 37 return "p in [namespace current]" 38 } 39 list [test_ns_1::baz::p] \ 40 [namespace eval test_ns_1 {baz::p}] \ 41 [info commands test_ns_1::baz::*] 42} -result {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p} 43test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} -setup { 44 catch {namespace delete {*}[namespace children :: test_ns_*]} 45} -returnCodes error -body { 46 proc test_ns_1::baz::p {} {} 47} -result {can't create procedure "test_ns_1::baz::p": unknown namespace} 48test proc-1.3 {Tcl_ProcObjCmd, empty proc name} -setup { 49 catch {namespace delete {*}[namespace children :: test_ns_*]} 50} -body { 51 proc :: {} { 52 return "empty called" 53 } 54 list [::] \ 55 [info body {}] 56} -result {{empty called} { 57 return "empty called" 58 }} 59test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} -setup { 60 catch {namespace delete {*}[namespace children :: test_ns_*]} 61} -body { 62 namespace eval test_ns_1 { 63 namespace eval baz { 64 proc p {} { 65 return "p in [namespace current]" 66 } 67 } 68 } 69 list [test_ns_1::baz::p] \ 70 [info commands test_ns_1::baz::*] 71} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p} 72test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} -setup { 73 catch {namespace delete {*}[namespace children :: test_ns_*]} 74} -body { 75 namespace eval test_ns_1::baz {} 76 namespace eval test_ns_1 { 77 proc baz::p {} { 78 return "p in [namespace current]" 79 } 80 } 81 list [test_ns_1::baz::p] \ 82 [info commands test_ns_1::baz::*] \ 83 [namespace eval test_ns_1::baz {namespace which p}] 84} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p} 85test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} -setup { 86 catch {namespace delete {*}[namespace children :: test_ns_*]} 87} -body { 88 namespace eval test_ns_1 { 89 proc q: {} {return "q:"} 90 proc value:at: {} {return "value:at:"} 91 } 92 list [namespace eval test_ns_1 {q:}] \ 93 [namespace eval test_ns_1 {value:at:}] \ 94 [test_ns_1::q:] \ 95 [test_ns_1::value:at:] \ 96 [lsort [info commands test_ns_1::*]] \ 97 [namespace eval test_ns_1 {namespace which q:}] \ 98 [namespace eval test_ns_1 {namespace which value:at:}] 99} -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:} 100test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup { 101 catch {rename p ""} 102} -returnCodes error -body { 103 proc p {a(1) a(2)} { 104 set z [expr {$a(1)+$a(2)}] 105 puts "$z=z, $a(1)=$a(1)" 106 } 107} -result {formal parameter "a(1)" is an array element} 108test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup { 109 catch {rename p ""} 110} -body { 111 proc p {b:a b::a} { 112 } 113} -returnCodes error -result {formal parameter "b::a" is not a simple name} 114test proc-1.9 {Tcl_ProcObjCmd, arguments via canonical list (string-representation bug [631b4c45df])} -body { 115 set v 2 116 binary scan AB cc a b 117 proc p [list [list a $a] [list b $b] [list v [expr {$v + 2}]]] {expr {$a + $b + $v}} 118 p 119} -result [expr {65+66+4}] -cleanup { 120 rename p {} 121} 122 123test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup { 124 catch {namespace delete {*}[namespace children :: test_ns_*]} 125 catch {rename p ""} 126} -body { 127 proc p {} {return "p in [namespace current]"} 128 info body p 129} -result {return "p in [namespace current]"} 130test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} -setup { 131 catch {namespace delete {*}[namespace children :: test_ns_*]} 132} -body { 133 namespace eval test_ns_1 { 134 namespace eval baz { 135 proc p {} {return "p in [namespace current]"} 136 } 137 } 138 namespace eval test_ns_1::baz {info body p} 139} -result {return "p in [namespace current]"} 140test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} -setup { 141 catch {namespace delete {*}[namespace children :: test_ns_*]} 142} -body { 143 namespace eval test_ns_1::baz {} 144 namespace eval test_ns_1 { 145 proc baz::p {} {return "p in [namespace current]"} 146 } 147 namespace eval test_ns_1 {info body baz::p} 148} -result {return "p in [namespace current]"} 149test proc-2.4 {TclFindProc, global proc and executing in namespace} -setup { 150 catch {namespace delete {*}[namespace children :: test_ns_*]} 151 catch {rename p ""} 152} -body { 153 proc p {} {return "global p"} 154 namespace eval test_ns_1::baz {info body p} 155} -result {return "global p"} 156 157test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} -setup { 158 catch {namespace delete {*}[namespace children :: test_ns_*]} 159} -body { 160 proc p {} {return "p in [namespace current]"} 161 p 162} -result {p in ::} 163test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} -setup { 164 catch {namespace delete {*}[namespace children :: test_ns_*]} 165} -body { 166 namespace eval test_ns_1::baz { 167 proc p {} {return "p in [namespace current]"} 168 p 169 } 170} -result {p in ::test_ns_1::baz} 171test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} -setup { 172 catch {namespace delete {*}[namespace children :: test_ns_*]} 173 catch {rename p ""} 174} -body { 175 proc p {} {return "p in [namespace current]"} 176 namespace eval test_ns_1::baz { 177 p 178 } 179} -result {p in ::} 180test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} -setup { 181 catch {namespace delete {*}[namespace children :: test_ns_*]} 182 catch {rename p ""} 183} -body { 184 namespace eval test_ns_1::baz { 185 proc p {} {return "p in [namespace current]"} 186 rename ::test_ns_1::baz::p ::p 187 list [p] [namespace which p] 188 } 189} -result {{p in ::} ::p} 190test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} -body { 191 proc p {x} {info commands 3m} 192 p 193} -returnCodes error -result {wrong # args: should be "p x"} 194test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} -body { 195 proc {a b c} {x} {info commands 3m} 196 {a b c} 197} -returnCodes error -result {wrong # args: should be "{a b c} x"} 198 199test proc-3.7 {TclObjInterpProc, wrong num args, Bug 3366265} { 200 proc {} {x} {} 201 list [catch {{}} msg] $msg 202} {1 {wrong # args: should be "{} x"}} 203 204catch {namespace delete {*}[namespace children :: test_ns_*]} 205catch {rename p ""} 206catch {rename {} ""} 207catch {rename {a b c} {}} 208catch {unset msg} 209 210catch {rename p ""} 211catch {rename t ""} 212 213# Note that the test require that procedures whose body is used to create 214# procbody objects must be executed before the tcl::procbodytest::proc command is 215# executed, so that the Proc struct is populated correctly (CompiledLocals are 216# added at compile time). 217 218test proc-4.1 {TclCreateProc, procbody obj} -constraints tcl::test -body { 219 proc p x {return "$x:$x"} 220 set rv [p P] 221 tcl::procbodytest::proc t x p 222 lappend rv [t T] 223} -cleanup { 224 catch {rename p ""} 225 catch {rename t ""} 226} -result {P:P T:T} 227test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} -body { 228 proc p x { 229 set y [string tolower $x] 230 return "$x:$y" 231 } 232 set rv [p P] 233 tcl::procbodytest::proc t x p 234 lappend rv [t T] 235} -constraints tcl::test -cleanup { 236 catch {rename p ""} 237 catch {rename t ""} 238} -result {P:p T:t} 239test proc-4.3 {TclCreateProc, procbody obj, too many args} -body { 240 proc p x { 241 set y [string tolower $x] 242 return "$x:$y" 243 } 244 set rv [p P] 245 tcl::procbodytest::proc t {x x1 x2} p 246 lappend rv [t T] 247} -constraints tcl::test -returnCodes error -cleanup { 248 catch {rename p ""} 249 catch {rename t ""} 250} -result {procedure "t": arg list contains 3 entries, precompiled header expects 1} 251test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} -body { 252 proc p {x y z} { 253 set v [join [list $x $y $z]] 254 set w [string tolower $v] 255 return "$v:$w" 256 } 257 set rv [p P Q R] 258 tcl::procbodytest::proc t {x x1 z} p 259 lappend rv [t S T U] 260} -constraints tcl::test -returnCodes error -cleanup { 261 catch {rename p ""} 262 catch {rename t ""} 263} -result {procedure "t": formal parameter 1 is inconsistent with precompiled body} 264test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body { 265 proc p {x y {z Z}} { 266 set v [join [list $x $y $z]] 267 set w [string tolower $v] 268 return "$v:$w" 269 } 270 set rv [p P Q R] 271 tcl::procbodytest::proc t {x y z} p 272 lappend rv [t S T U] 273} -constraints tcl::test -returnCodes error -cleanup { 274 catch {rename p ""} 275 catch {rename t ""} 276} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} 277test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body { 278 proc p {x y z} { 279 set v [join [list $x $y $z]] 280 set w [string tolower $v] 281 return "$v:$w" 282 } 283 set rv [p P Q R] 284 tcl::procbodytest::proc t {x y {z Z}} p 285 lappend rv [t S T U] 286} -returnCodes error -constraints tcl::test -cleanup { 287 catch {rename p ""} 288 catch {rename t ""} 289} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} 290test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -body { 291 proc p {x y {z Z}} { 292 set v [join [list $x $y $z]] 293 set w [string tolower $v] 294 return "$v:$w" 295 } 296 set rv [p P Q R] 297 tcl::procbodytest::proc t {x y {z ZZ}} p 298 lappend rv [t S T U] 299} -constraints tcl::test -returnCodes error -cleanup { 300 catch {rename p ""} 301 catch {rename t ""} 302} -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} 303test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup { 304 proc getbytes {} { 305 set lines [split [memory info] "\n"] 306 lindex $lines 3 3 307 } 308 proc px x { 309 set y [string tolower $x] 310 return "$x:$y" 311 } 312 px x 313} -constraints {tcl::test memory} -body { 314 set end [getbytes] 315 for {set i 0} {$i < 5} {incr i} { 316 tcl::procbodytest::proc tx x px 317 set tmp $end 318 set end [getbytes] 319 } 320 set leakedBytes [expr {$end - $tmp}] 321} -cleanup { 322 rename getbytes {} 323 unset -nocomplain end i tmp leakedBytes 324} -result 0 325test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} tcl::test { 326 tcl::procbodytest::check 327} 1 328 329test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body { 330 proc p args {} ; # this will be bytecompiled into t 331 proc t {} { 332 set res {} 333 set a 0 334 set b 0 335 trace add variable a read {append res a ;#} 336 trace add variable b write {append res b ;#} 337 p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello 338 set res 339 } 340 t 341} -cleanup { 342 catch {rename p ""} 343 catch {rename t ""} 344} -result {aba} 345 346test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} -body { 347 proc a {} {return -code -5} 348 proc b {} a 349 catch b 350} -cleanup { 351 rename a {} 352 rename b {} 353} -result -5 354 355test proc-7.1 {Redefining a compiled cmd: Bug 729692} { 356 proc bar args {} 357 proc foo {} { 358 proc bar args {return bar} 359 bar 360 } 361 foo 362} bar 363test proc-7.2 {Shadowing a compiled cmd: Bug 729692} -body { 364 namespace eval ugly {} 365 proc ugly::foo {} { 366 proc set args {return bar} 367 set x 1 368 } 369 ugly::foo 370} -cleanup { 371 namespace delete ugly 372} -result bar 373test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body { 374 namespace eval ugly {} 375 proc ugly::foo {} { 376 set i 0 377 while { 1 } { 378 if { [incr i] > 3 } { 379 proc continue {} {return -code break} 380 } 381 continue 382 } 383 return $i 384 } 385 ugly::foo 386} -cleanup { 387 namespace delete ugly 388} -result 4 389 390test proc-7.4 {Proc struct outlives its interp: Bug 3532959} { 391 set lambda x 392 lappend lambda {set a 1} 393 interp create child 394 child eval [list apply $lambda foo] 395 interp delete child 396 unset lambda 397} {} 398 399test proc-7.5 {[631b4c45df] Crash in argument processing} { 400 binary scan A c val 401 proc foo [list [list from $val]] {} 402 rename foo {} 403 unset -nocomplain val 404} {} 405 406 407# cleanup 408catch {rename p ""} 409catch {rename t ""} 410::tcltest::cleanupTests 411return 412 413# Local Variables: 414# mode: tcl 415# fill-column: 78 416# End: 417