1# Commands covered: proc, return, global 2# 3# This file, proc-old.test, includes the original set of tests for Tcl's 4# proc, return, and global commands. There is now a new file proc.test 5# that contains tests for the tclProc.c source file. 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 © 1991-1993 The Regents of the University of California. 11# Copyright © 1994-1997 Sun Microsystems, Inc. 12# Copyright © 1998-1999 Scriptics Corporation. 13# 14# See the file "license.terms" for information on usage and redistribution 15# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 16 17if {"::tcltest" ni [namespace children]} { 18 package require tcltest 2.5 19 namespace import -force ::tcltest::* 20} 21 22catch {rename t1 ""} 23catch {rename foo ""} 24 25proc tproc {} {return a; return b} 26test proc-old-1.1 {simple procedure call and return} {tproc} a 27proc tproc x { 28 set x [expr {$x + 1}] 29 return $x 30} 31test proc-old-1.2 {simple procedure call and return} {tproc 2} 3 32test proc-old-1.3 {simple procedure call and return} { 33 proc tproc {} {return foo} 34} {} 35test proc-old-1.4 {simple procedure call and return} { 36 proc tproc {} {return} 37 tproc 38} {} 39proc tproc1 {a} {incr a; return $a} 40proc tproc2 {a b} {incr a; return $a} 41test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} { 42 list [tproc1 123] [tproc2 456 789] 43} {124 457} 44test proc-old-1.6 {simple procedure call and return (shared proc body string)} { 45 set x {} 46 proc tproc {} {} ;# body is shared with x 47 list [tproc] [append x foo] 48} {{} foo} 49 50test proc-old-2.1 {local and global variables} { 51 proc tproc x { 52 set x [expr {$x + 1}] 53 return $x 54 } 55 set x 42 56 list [tproc 6] $x 57} {7 42} 58test proc-old-2.2 {local and global variables} { 59 proc tproc x { 60 set y [expr {$x + 1}] 61 return $y 62 } 63 set y 18 64 list [tproc 6] $y 65} {7 18} 66test proc-old-2.3 {local and global variables} { 67 proc tproc x { 68 global y 69 set y [expr {$x + 1}] 70 return $y 71 } 72 set y 189 73 list [tproc 6] $y 74} {7 7} 75test proc-old-2.4 {local and global variables} { 76 proc tproc x { 77 global y 78 return [expr {$x + $y}] 79 } 80 set y 189 81 list [tproc 6] $y 82} {195 189} 83catch {unset _undefined_} 84test proc-old-2.5 {local and global variables} { 85 proc tproc x { 86 global _undefined_ 87 return $_undefined_ 88 } 89 list [catch {tproc xxx} msg] $msg 90} {1 {can't read "_undefined_": no such variable}} 91test proc-old-2.6 {local and global variables} { 92 set a 114 93 set b 115 94 global a b 95 list $a $b 96} {114 115} 97 98proc do {cmd} {eval $cmd} 99test proc-old-3.1 {local and global arrays} { 100 catch {unset a} 101 set a(0) 22 102 list [catch {do {global a; set a(0)}} msg] $msg 103} {0 22} 104test proc-old-3.2 {local and global arrays} { 105 catch {unset a} 106 set a(x) 22 107 list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x) 108} {0 newValue newValue} 109test proc-old-3.3 {local and global arrays} { 110 catch {unset a} 111 set a(x) 22 112 set a(y) 33 113 list [catch {do {global a; unset a(y)}; array names a} msg] $msg 114} {0 x} 115test proc-old-3.4 {local and global arrays} { 116 catch {unset a} 117 set a(x) 22 118 set a(y) 33 119 list [catch {do {global a; unset a; info exists a}} msg] $msg \ 120 [info exists a] 121} {0 0 0} 122test proc-old-3.5 {local and global arrays} { 123 catch {unset a} 124 set a(x) 22 125 set a(y) 33 126 list [catch {do {global a; unset a(y); array names a}} msg] $msg 127} {0 x} 128catch {unset a} 129test proc-old-3.6 {local and global arrays} { 130 catch {unset a} 131 set a(x) 22 132 set a(y) 33 133 do {global a; do {global a; unset a}; set a(z) 22} 134 list [catch {array names a} msg] $msg 135} {0 z} 136test proc-old-3.7 {local and global arrays} { 137 proc t1 {args} {global info; set info 1} 138 catch {unset a} 139 set info {} 140 do {global a; trace var a(1) w t1} 141 set a(1) 44 142 set info 143} 1 144test proc-old-3.8 {local and global arrays} { 145 proc t1 {args} {global info; set info 1} 146 catch {unset a} 147 trace var a(1) w t1 148 set info {} 149 do {global a; trace vdelete a(1) w t1} 150 set a(1) 44 151 set info 152} {} 153test proc-old-3.9 {local and global arrays} { 154 proc t1 {args} {global info; set info 1} 155 catch {unset a} 156 trace var a(1) w t1 157 do {global a; trace vinfo a(1)} 158} {{w t1}} 159catch {unset a} 160 161test proc-old-30.1 {arguments and defaults} { 162 proc tproc {x y z} { 163 return [list $x $y $z] 164 } 165 tproc 11 12 13 166} {11 12 13} 167test proc-old-30.2 {arguments and defaults} { 168 proc tproc {x y z} { 169 return [list $x $y $z] 170 } 171 list [catch {tproc 11 12} msg] $msg 172} {1 {wrong # args: should be "tproc x y z"}} 173test proc-old-30.3 {arguments and defaults} { 174 proc tproc {x y z} { 175 return [list $x $y $z] 176 } 177 list [catch {tproc 11 12 13 14} msg] $msg 178} {1 {wrong # args: should be "tproc x y z"}} 179test proc-old-30.4 {arguments and defaults} { 180 proc tproc {x {y y-default} {z z-default}} { 181 return [list $x $y $z] 182 } 183 tproc 11 12 13 184} {11 12 13} 185test proc-old-30.5 {arguments and defaults} { 186 proc tproc {x {y y-default} {z z-default}} { 187 return [list $x $y $z] 188 } 189 tproc 11 12 190} {11 12 z-default} 191test proc-old-30.6 {arguments and defaults} { 192 proc tproc {x {y y-default} {z z-default}} { 193 return [list $x $y $z] 194 } 195 tproc 11 196} {11 y-default z-default} 197test proc-old-30.7 {arguments and defaults} { 198 proc tproc {x {y y-default} {z z-default}} { 199 return [list $x $y $z] 200 } 201 list [catch {tproc} msg] $msg 202} {1 {wrong # args: should be "tproc x ?y? ?z?"}} 203test proc-old-30.8 {arguments and defaults} { 204 list [catch { 205 proc tproc {x {y y-default} z} { 206 return [list $x $y $z] 207 } 208 tproc 2 3 209 } msg] $msg 210} {1 {wrong # args: should be "tproc x ?y? z"}} 211test proc-old-30.9 {arguments and defaults} { 212 proc tproc {x {y y-default} args} { 213 return [list $x $y $args] 214 } 215 tproc 2 3 4 5 216} {2 3 {4 5}} 217test proc-old-30.10 {arguments and defaults} { 218 proc tproc {x {y y-default} args} { 219 return [list $x $y $args] 220 } 221 tproc 2 3 222} {2 3 {}} 223test proc-old-30.11 {arguments and defaults} { 224 proc tproc {x {y y-default} args} { 225 return [list $x $y $args] 226 } 227 tproc 2 228} {2 y-default {}} 229test proc-old-30.12 {arguments and defaults} { 230 proc tproc {x {y y-default} args} { 231 return [list $x $y $args] 232 } 233 list [catch {tproc} msg] $msg 234} {1 {wrong # args: should be "tproc x ?y? ?arg ...?"}} 235 236test proc-old-4.1 {variable numbers of arguments} { 237 proc tproc args {return $args} 238 tproc 239} {} 240test proc-old-4.2 {variable numbers of arguments} { 241 proc tproc args {return $args} 242 tproc 1 2 3 4 5 6 7 8 243} {1 2 3 4 5 6 7 8} 244test proc-old-4.3 {variable numbers of arguments} { 245 proc tproc args {return $args} 246 tproc 1 {2 3} {4 {5 6} {{{7}}}} 8 247} {1 {2 3} {4 {5 6} {{{7}}}} 8} 248test proc-old-4.4 {variable numbers of arguments} { 249 proc tproc {x y args} {return $args} 250 tproc 1 2 3 4 5 6 7 251} {3 4 5 6 7} 252test proc-old-4.5 {variable numbers of arguments} { 253 proc tproc {x y args} {return $args} 254 tproc 1 2 255} {} 256test proc-old-4.6 {variable numbers of arguments} { 257 proc tproc {x missing args} {return $args} 258 list [catch {tproc 1} msg] $msg 259} {1 {wrong # args: should be "tproc x missing ?arg ...?"}} 260 261test proc-old-5.1 {error conditions} { 262 list [catch {proc} msg] $msg 263} {1 {wrong # args: should be "proc name args body"}} 264test proc-old-5.2 {error conditions} { 265 list [catch {proc tproc b} msg] $msg 266} {1 {wrong # args: should be "proc name args body"}} 267test proc-old-5.3 {error conditions} { 268 list [catch {proc tproc b c d e} msg] $msg 269} {1 {wrong # args: should be "proc name args body"}} 270test proc-old-5.4 {error conditions} { 271 list [catch {proc tproc \{xyz {return foo}} msg] $msg 272} {1 {unmatched open brace in list}} 273test proc-old-5.5 {error conditions} { 274 list [catch {proc tproc {{} y} {return foo}} msg] $msg 275} {1 {argument with no name}} 276test proc-old-5.6 {error conditions} { 277 list [catch {proc tproc {{} y} {return foo}} msg] $msg 278} {1 {argument with no name}} 279test proc-old-5.7 {error conditions} { 280 list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg 281} {1 {too many fields in argument specifier "x 1 2"}} 282test proc-old-5.8 {error conditions} { 283 catch {return} 284} 2 285proc tproc {} { 286 set a 22 287 global a 288} 289test proc-old-5.10 {error conditions} { 290 list [catch {tproc} msg] $msg 291} {1 {variable "a" already exists}} 292test proc-old-5.11 {error conditions} { 293 catch {rename tproc {}} 294 catch { 295 proc tproc {x {} z} {return foo} 296 } 297 list [catch {tproc 1} msg] $msg 298} {1 {invalid command name "tproc"}} 299test proc-old-5.12 {error conditions} { 300 proc tproc {} { 301 set a 22 302 error "error in procedure" 303 return 304 } 305 list [catch tproc msg] $msg 306} {1 {error in procedure}} 307test proc-old-5.13 {error conditions} { 308 proc tproc {} { 309 set a 22 310 error "error in procedure" 311 return 312 } 313 catch tproc msg 314 set ::errorInfo 315} {error in procedure 316 while executing 317"error "error in procedure"" 318 (procedure "tproc" line 3) 319 invoked from within 320"tproc"} 321test proc-old-5.14 {error conditions} { 322 proc tproc {} { 323 set a 22 324 break 325 return 326 } 327 catch tproc msg 328 set ::errorInfo 329} {invoked "break" outside of a loop 330 (procedure "tproc" line 1) 331 invoked from within 332"tproc"} 333test proc-old-5.15 {error conditions} { 334 proc tproc {} { 335 set a 22 336 continue 337 return 338 } 339 catch tproc msg 340 set ::errorInfo 341} {invoked "continue" outside of a loop 342 (procedure "tproc" line 1) 343 invoked from within 344"tproc"} 345test proc-old-5.16 {error conditions} { 346 proc foo args { 347 global fooMsg 348 set fooMsg "foo was called: $args" 349 } 350 proc tproc {} { 351 set x 44 352 trace var x u foo 353 while {$x < 100} { 354 error "Nested error" 355 } 356 } 357 set fooMsg "foo not called" 358 list [catch tproc msg] $msg $::errorInfo $fooMsg 359} {1 {Nested error} {Nested error 360 while executing 361"error "Nested error"" 362 (procedure "tproc" line 5) 363 invoked from within 364"tproc"} {foo was called: x {} u}} 365 366# The tests below will really only be useful when run under Purify or 367# some other system that can detect accesses to freed memory... 368 369test proc-old-6.1 {procedure that redefines itself} { 370 proc tproc {} { 371 proc tproc {} { 372 return 44 373 } 374 return 45 375 } 376 tproc 377} 45 378test proc-old-6.2 {procedure that deletes itself} { 379 proc tproc {} { 380 rename tproc {} 381 return 45 382 } 383 tproc 384} 45 385 386proc tproc code { 387 return -code $code abc 388} 389test proc-old-7.1 {return with special completion code} { 390 list [catch {tproc ok} msg] $msg 391} {0 abc} 392test proc-old-7.2 {return with special completion code} { 393 list [catch {tproc error} msg] $msg $::errorInfo $::errorCode 394} {1 abc {abc 395 while executing 396"tproc error"} NONE} 397test proc-old-7.3 {return with special completion code} { 398 list [catch {tproc return} msg] $msg 399} {2 abc} 400test proc-old-7.4 {return with special completion code} { 401 list [catch {tproc break} msg] $msg 402} {3 abc} 403test proc-old-7.5 {return with special completion code} { 404 list [catch {tproc continue} msg] $msg 405} {4 abc} 406test proc-old-7.6 {return with special completion code} { 407 list [catch {tproc -14} msg] $msg 408} {-14 abc} 409test proc-old-7.7 {return with special completion code} -body { 410 tproc err 411} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer} 412test proc-old-7.8 {return with special completion code} -body { 413 tproc 10b 414} -returnCodes error -match glob -result {bad completion code "10b": must be ok, error, return, break, continue*, or an integer} 415test proc-old-7.9 {return with special completion code} { 416 proc tproc2 {} { 417 tproc return 418 } 419 list [catch tproc2 msg] $msg 420} {0 abc} 421test proc-old-7.10 {return with special completion code} { 422 proc tproc2 {} { 423 return -code error 424 } 425 list [catch tproc2 msg] $msg 426} {1 {}} 427test proc-old-7.11 {return with special completion code} { 428 proc tproc2 {} { 429 global errorCode errorInfo 430 catch {open _bad_file_name r} msg 431 return -code error -errorinfo $errorInfo -errorcode $errorCode $msg 432 } 433 set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode] 434 regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg 435 normalizeMsg $msg 436} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory 437 while executing 438"open _bad_file_name r" 439 invoked from within 440"tproc2"} {posix enoent {no such file or directory}}} 441test proc-old-7.12 {return with special completion code} { 442 proc tproc2 {} { 443 global errorCode errorInfo 444 catch {open _bad_file_name r} msg 445 return -code error -errorcode $errorCode $msg 446 } 447 set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode] 448 regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg 449 normalizeMsg $msg 450} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory 451 while executing 452"tproc2"} {posix enoent {no such file or directory}}} 453test proc-old-7.13 {return with special completion code} { 454 proc tproc2 {} { 455 global errorCode errorInfo 456 catch {open _bad_file_name r} msg 457 return -code error -errorinfo $errorInfo $msg 458 } 459 set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode] 460 regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg 461 normalizeMsg $msg 462} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory 463 while executing 464"open _bad_file_name r" 465 invoked from within 466"tproc2"} none} 467test proc-old-7.14 {return with special completion code} { 468 proc tproc2 {} { 469 global errorCode errorInfo 470 catch {open _bad_file_name r} msg 471 return -code error $msg 472 } 473 set msg [list [catch tproc2 msg] $msg $::errorInfo $::errorCode] 474 regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg 475 normalizeMsg $msg 476} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory 477 while executing 478"tproc2"} none} 479test proc-old-7.15 {return with special completion code} { 480 list [catch {return -badOption foo message} msg] $msg 481} {2 message} 482 483test proc-old-8.1 {unset and undefined local arrays} { 484 proc t1 {} { 485 foreach v {xxx, yyy} { 486 catch {unset $v} 487 } 488 set yyy(foo) bar 489 } 490 t1 491} bar 492 493test proc-old-9.1 {empty command name} { 494 catch {rename {} ""} 495 proc t1 {args} { 496 return 497 } 498 set v [t1] 499 catch {$v} 500} 1 501 502test proc-old-10.1 {ByteCode epoch change during recursive proc execution} { 503 proc t1 x { 504 set y 20 505 rename expr expr.old 506 rename expr.old expr 507 if {$x} then {t1 0} ;# recursive call after foo's code is invalidated 508 return 20 509 } 510 t1 1 511} 20 512 513# cleanup 514catch {rename t1 ""} 515catch {rename foo ""} 516::tcltest::cleanupTests 517return 518