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