util/src/TclTk/tcl8.6.12/tests/proc.test

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