1# The tests in this file cover the procedures in tclCmdMZ.c. 2# 3# This file contains a collection of tests for one or more of the Tcl built-in 4# commands. Sourcing this file into Tcl runs the tests and generates output 5# for errors. No output means no errors were found. 6# 7# Copyright © 1991-1993 The Regents of the University of California. 8# Copyright © 1994 Sun Microsystems, Inc. 9# Copyright © 1998-1999 Scriptics Corporation. 10# 11# See the file "license.terms" for information on usage and redistribution of 12# this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17} 18 19namespace eval ::tcl::test::cmdMZ { 20 namespace import ::tcltest::cleanupTests 21 namespace import ::tcltest::customMatch 22 namespace import ::tcltest::makeFile 23 namespace import ::tcltest::removeFile 24 namespace import ::tcltest::temporaryDirectory 25 namespace import ::tcltest::testConstraint 26 namespace import ::tcltest::test 27 28 proc ListGlobMatch {expected actual} { 29 if {[llength $expected] != [llength $actual]} { 30 return 0 31 } 32 foreach e $expected a $actual { 33 if {![string match $e $a]} { 34 return 0 35 } 36 } 37 return 1 38 } 39 customMatch listGlob [namespace which ListGlobMatch] 40 41# Tcl_PwdObjCmd 42 43test cmdMZ-1.1 {Tcl_PwdObjCmd} -returnCodes error -body { 44 pwd a 45} -result {wrong # args: should be "pwd"} 46test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} { 47 catch pwd 48} 0 49test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} -body { 50 pwd 51} -match glob -result {?*} 52test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} -setup { 53 set cwd [pwd] 54 set foodir [file join [temporaryDirectory] foo] 55 file delete -force $foodir 56 file mkdir $foodir 57 cd $foodir 58} -constraints {unix nonPortable} -body { 59 # This test fails on various unix platforms (eg Linux) where permissions 60 # caching causes this to fail. The caching is strictly incorrect, but we 61 # have no control over that. 62 file attr . -permissions 0 63 pwd 64} -returnCodes error -cleanup { 65 cd $cwd 66 file delete -force $foodir 67} -result {error getting working directory name: permission denied} 68 69# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test 70 71# Tcl_RenameObjCmd 72 73test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} -returnCodes error -body { 74 rename r1 75} -result {wrong # args: should be "rename oldName newName"} 76test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} -returnCodes error -body { 77 rename r1 r2 r3 78} -result {wrong # args: should be "rename oldName newName"} 79test cmdMZ-2.3 {Tcl_RenameObjCmd: success} -setup { 80 catch {rename r2 {}} 81} -body { 82 proc r1 {} {return "r1"} 83 rename r1 r2 84 r2 85} -result {r1} 86test cmdMZ-2.4 {Tcl_RenameObjCmd: success} { 87 proc r1 {} {return "r1"} 88 rename r1 {} 89 list [catch {r1} msg] $msg 90} {1 {invalid command name "r1"}} 91 92# Some tests for Tcl_ReturnObjCmd are in proc-old.test 93 94test cmdMZ-return-1.0 {return checks for bad option values} -body { 95 return -options foo 96} -returnCodes error -match glob -result {bad -options value:*} 97test cmdMZ-return-1.1 {return checks for bad option values} -body { 98 return -code err 99} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer} 100test cmdMZ-return-1.2 {return checks for bad option values} -body { 101 return -code 0x100000000 102} -returnCodes error -match glob -result {bad completion code "0x100000000": must be ok, error, return, break, continue*, or an integer} 103test cmdMZ-return-1.3 {return checks for bad option values} -body { 104 return -level foo 105} -returnCodes error -match glob -result {bad -level value: *} 106test cmdMZ-return-1.4 {return checks for bad option values} -body { 107 return -level -1 108} -returnCodes error -match glob -result {bad -level value: *} 109test cmdMZ-return-1.5 {return checks for bad option values} -body { 110 return -level 3.1415926 111} -returnCodes error -match glob -result {bad -level value: *} 112 113proc dictSort {d} { 114 set result {} 115 foreach k [lsort [dict keys $d]] { 116 dict set result $k [dict get $d $k] 117 } 118 return $result 119} 120 121test cmdMZ-return-2.0 {return option handling} { 122 list [catch return -> foo] [dictSort $foo] 123} {2 {-code 0 -level 1}} 124test cmdMZ-return-2.1 {return option handling} { 125 list [catch {return -bar soom} -> foo] [dictSort $foo] 126} {2 {-bar soom -code 0 -level 1}} 127test cmdMZ-return-2.2 {return option handling} { 128 list [catch {return -code return} -> foo] [dictSort $foo] 129} {2 {-code 0 -level 2}} 130test cmdMZ-return-2.3 {return option handling} { 131 list [catch {return -code return -level 10} -> foo] [dictSort $foo] 132} {2 {-code 0 -level 11}} 133test cmdMZ-return-2.4 {return option handling} -body { 134 return -level 0 -code error 135} -returnCodes error -result {} 136test cmdMZ-return-2.5 {return option handling} -body { 137 return -level 0 -code return 138} -returnCodes return -result {} 139test cmdMZ-return-2.6 {return option handling} -body { 140 return -level 0 -code break 141} -returnCodes break -result {} 142test cmdMZ-return-2.7 {return option handling} -body { 143 return -level 0 -code continue 144} -returnCodes continue -result {} 145test cmdMZ-return-2.8 {return option handling} -body { 146 return -level 0 -code -1 147} -returnCodes -1 -result {} 148test cmdMZ-return-2.9 {return option handling} -body { 149 return -level 0 -code 10 150} -returnCodes 10 -result {} 151test cmdMZ-return-2.10 {return option handling} -body { 152 list [catch {return -level 0 -code error} -> foo] [dictSort $foo] 153} -match glob -result {1 {-code 1 -errorcode NONE -errorinfo { 154 while executing 155"return -level 0 -code error"} -errorline 1 -errorstack * -level 0}} 156test cmdMZ-return-2.11 {return option handling} { 157 list [catch {return -level 0 -code break} -> foo] [dictSort $foo] 158} {3 {-code 3 -level 0}} 159test cmdMZ-return-2.12 {return option handling} -body { 160 return -level 0 -code error -options {-code ok} 161} -returnCodes ok -result {} 162test cmdMZ-return-2.13 {return option handling} -body { 163 return -level 0 -code error -options {-code err} 164} -returnCodes error -match glob -result {bad completion code "err": must be ok, error, return, break, continue*, or an integer} 165test cmdMZ-return-2.14 {return option handling} -body { 166 return -level 0 -code error -options {-code foo -options {-code break}} 167} -returnCodes break -result {} 168test cmdMZ-return-2.15 {return opton handling} { 169 list [catch { 170 apply {{} { 171 return -code error -errorcode {a b} c 172 }} 173 } result] $result $::errorCode 174} {1 c {a b}} 175test cmdMZ-return-2.16 {return opton handling} { 176 list [catch { 177 apply {{} { 178 return -code error -errorcode [list a b] c 179 }} 180 } result] $result $::errorCode 181} {1 c {a b}} 182test cmdMZ-return-2.17 {return opton handling} { 183 list [catch { 184 apply {{} { 185 return -code error -errorcode a\ b c 186 }} 187 } result] $result $::errorCode 188} {1 c {a b}} 189test cmdMZ-return-2.18 {return option handling} { 190 list [catch { 191 return -code error -errorstack [list CALL a CALL b] yo 192 } -> foo] [dictSort $foo] [info errorstack] 193} {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}} 194 195# Check that the result of a [return -options $opts $result] is 196# indistinguishable from that of the originally caught script, no matter what 197# the script is/does. (TIP 90) 198foreach {testid script} { 199 cmdMZ-return-3.0 {} 200 cmdMZ-return-3.1 {format x} 201 cmdMZ-return-3.2 {set} 202 cmdMZ-return-3.3 {set a 1} 203 cmdMZ-return-3.4 {error} 204 cmdMZ-return-3.5 {error foo} 205 cmdMZ-return-3.6 {error foo bar} 206 cmdMZ-return-3.7 {error foo bar baz} 207 cmdMZ-return-3.8 {return -level 0} 208 cmdMZ-return-3.9 {return -code error} 209 cmdMZ-return-3.10 {return -code error -errorinfo foo} 210 cmdMZ-return-3.11 {return -code error -errorinfo foo -errorcode bar} 211 cmdMZ-return-3.12 {return -code error -errorinfo foo -errorcode bar -errorline 10} 212 cmdMZ-return-3.12.1 {return -code error -errorinfo foo -errorcode bar -errorline 10 -errorstack baz} 213 cmdMZ-return-3.13 {return -options {x y z 2}} 214 cmdMZ-return-3.14 {return -level 3 -code break sdf} 215} { 216 test $testid "check that return after a catch is same:\n$script" { 217 set one [list [catch $script foo bar] $foo [dictSort $bar] \ 218 $::errorCode $::errorInfo] 219 set two [list [catch {return -options $bar $foo} foo2 bar2] \ 220 $foo2 [dictSort $bar2] $::errorCode $::errorInfo] 221 string equal $one $two 222 } 1 223} 224 225# The tests for Tcl_ScanObjCmd are in scan.test 226 227# Tcl_SourceObjCmd 228# More tests of Tcl_SourceObjCmd are in source.test 229 230test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { 231 unixOrWin 232} -returnCodes error -body { 233 source 234} -match glob -result {wrong # args: should be "source*fileName"} 235test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { 236 unixOrWin 237} -returnCodes error -body { 238 source a b c d e f 239} -match glob -result {wrong # args: should be "source*fileName"} 240test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { 241 set file [makeFile { 242 set x 146 243 error "error in sourced file" 244 set y $x 245 } source.file] 246 list [catch {source $file} msg] $msg $::errorInfo 247} -cleanup { 248 removeFile source.file 249} -match listGlob -result {1 {error in sourced file} {error in sourced file 250 while executing 251"error "error in sourced file"" 252 (file "*" line 3) 253 invoked from within 254"source $file"}} 255test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} -body { 256 set file [makeFile {list ok} source.file] 257 source $file 258} -cleanup { 259 removeFile source.file 260} -result ok 261 262# Tcl_SplitObjCmd 263 264test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} -returnCodes error -body { 265 split 266} -result {wrong # args: should be "split string ?splitChars?"} 267test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} -returnCodes error -body { 268 split a b c 269} -result {wrong # args: should be "split string ?splitChars?"} 270test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} { 271 split "a\n b\t\r c\n " 272} {a {} b {} {} c {} {}} 273test cmdMZ-4.4 {Tcl_SplitObjCmd: basic split commands} { 274 split "word 1xyzword 2zword 3" xyz 275} {{word 1} {} {} {word 2} {word 3}} 276test cmdMZ-4.5 {Tcl_SplitObjCmd: basic split commands} { 277 split "12345" {} 278} {1 2 3 4 5} 279test cmdMZ-4.6 {Tcl_SplitObjCmd: basic split commands} { 280 split "a\}b\[c\{\]\$" 281} "a\\\}b\\\[c\\\{\\\]\\\$" 282test cmdMZ-4.7 {Tcl_SplitObjCmd: basic split commands} { 283 split {} {} 284} {} 285test cmdMZ-4.8 {Tcl_SplitObjCmd: basic split commands} { 286 split {} 287} {} 288test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} { 289 split { } 290} {{} {} {} {}} 291test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} { 292 apply {{} { 293 set x {} 294 foreach f [split {]\n} {}] { 295 append x $f 296 } 297 return $x 298 }} 299} {]\n} 300test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} { 301 apply {{} { 302 set x ab\x00c 303 set y [split $x {}] 304 binary scan $y c* z 305 return $z 306 }} 307} {97 32 98 32 0 32 99} 308test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} { 309 split "a0ab1b2bbb3\x00c4" ab\x00c 310} {{} 0 {} 1 2 {} {} 3 {} 4} 311test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { 312 # if not UTF-8 aware, result is "a {} {} b qwå {} N wq" 313 split "a乎b qw幎N wq" " 乎" 314} "a b qw幎N wq" 315 316# The tests for Tcl_StringObjCmd are in string.test 317# The tests for Tcl_SubstObjCmd are in subst.test 318# The tests for Tcl_SwitchObjCmd are in switch.test 319 320# todo: rewrite this if monotonic clock is provided resp. command "after" 321# gets microsecond accuracy (RFE [fdfbd5e10] gets merged): 322proc _nrt_sleep {msec} { 323 set usec [expr {$msec * 1000}] 324 set stime [clock microseconds] 325 while {abs([clock microseconds] - $stime) < $usec} { 326 # don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise): 327 # after 0 328 } 329} 330_nrt_sleep 0; # warm up (clock, compile, etc) 331 332test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body { 333 time 334} -returnCodes error -result {wrong # args: should be "time command ?count?"} 335test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body { 336 time a b c 337} -returnCodes error -result {wrong # args: should be "time command ?count?"} 338test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body { 339 time a b 340} -returnCodes error -result {expected integer but got "b"} 341test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} { 342 time bogusCmd -12456 343} {0 microseconds per iteration} 344test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body { 345 time {format 1} 346} -match regexp -result {^\d+ microseconds per iteration} 347test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} -body { 348 set m1 [lindex [time {_nrt_sleep 0.01}] 0] 349 set m2 [lindex [time {_nrt_sleep 10.0}] 0] 350 list \ 351 [expr {$m1 < $m2}] \ 352 $m1 $m2; # interesting only in error case. 353} -match glob -result [list 1 *] 354test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { 355 list [catch {time {error foo}} msg] $msg $::errorInfo 356} {1 foo {foo 357 while executing 358"error foo" 359 invoked from within 360"time {error foo}"}} 361test cmdMZ-5.7.1 {Tcl_TimeObjCmd: return from time} { 362 set x 0 363 proc r1 {} {upvar x x; time {incr x; return "r1"; incr x} 10} 364 list [r1] $x 365} {r1 1} 366test cmdMZ-5.8 {Tcl_TimeObjCmd: done optimization: nested call of self inside time (if compiled)} { 367 set x [set y 0] 368 set m1 { 369 if {[incr x] <= 5} { 370 # nested call should return result, so covering that: 371 if {![string is integer -strict [eval $m1]]} {error unexpected} 372 } 373 # increase again (no "continue" from nested call): 374 incr x 375 } 376 time {incr y; eval $m1} 5 377 list $y $x 378} {5 20} 379 380test cmdMZ-6.1 {Tcl_TimeRateObjCmd: basic format of command} { 381 list [catch {timerate} msg] $msg 382} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}} 383test cmdMZ-6.2.1 {Tcl_TimeRateObjCmd: basic format of command} { 384 list [catch {timerate a b c d} msg] $msg 385} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}} 386test cmdMZ-6.2.2 {Tcl_TimeRateObjCmd: basic format of command} { 387 list [catch {timerate a b c} msg] $msg 388} {1 {expected integer but got "b"}} 389test cmdMZ-6.2.3 {Tcl_TimeRateObjCmd: basic format of command} { 390 list [catch {timerate a b} msg] $msg 391} {1 {expected integer but got "b"}} 392test cmdMZ-6.3 {Tcl_TimeRateObjCmd: basic format of command} { 393 list [catch {timerate -overhead b {} a b} msg] $msg 394} {1 {expected floating-point number but got "b"}} 395test cmdMZ-6.4 {Tcl_TimeRateObjCmd: compile of script happens even with negative iteration counts} { 396 list [catch {timerate "foreach a {c d e} \{" -12456} msg] $msg 397} {1 {missing close-brace}} 398test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} { 399 regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0] 400} 1 401test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} { 402 regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0] 403} 1 404test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} -body { 405 set m1 [timerate {_nrt_sleep 0.01} 50] 406 set m2 [timerate {_nrt_sleep 1.00} 50] 407 list [list \ 408 [expr {[lindex $m1 0] < [lindex $m2 0]}] \ 409 [expr {[lindex $m1 0] < 100}] \ 410 [expr {[lindex $m2 0] > 100}] \ 411 [expr {[lindex $m1 2] > 500}] \ 412 [expr {[lindex $m2 2] < 500}] \ 413 [expr {[lindex $m1 4] > 10000}] \ 414 [expr {[lindex $m2 4] < 10000}] \ 415 [expr {[lindex $m1 6] > 5 && [lindex $m1 6] < 100}] \ 416 [expr {[lindex $m2 6] > 5 && [lindex $m2 6] < 100}] \ 417 ] $m1 $m2; # interesting only in error case. 418} -match glob -result [list [lrepeat 9 1] *] 419test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} { 420 list [catch {timerate {error foo} 1} msg] $msg $::errorInfo 421} {1 foo {foo 422 while executing 423"error foo" 424 invoked from within 425"timerate {error foo} 1"}} 426test cmdMZ-6.7.1 {Tcl_TimeRateObjCmd: return from timerate} { 427 set x 0 428 proc r1 {} {upvar x x; timerate {incr x; return "r1"; incr x} 1000 10} 429 list [r1] $x 430} {r1 1} 431test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} -body { 432 set m1 [timerate {break}] 433 list [list \ 434 [expr {[lindex $m1 0] < 1000}] \ 435 [expr {[lindex $m1 2] == 1}] \ 436 [expr {[lindex $m1 4] > 1000}] \ 437 [expr {[lindex $m1 6] < 10}] \ 438 ] $m1; # interesting only in error case. 439} -match glob -result [list {1 1 1 1} *] 440test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} -body { 441 set m1 [timerate {continue; return -code error "unexpected"} 1000 10] 442 list [list \ 443 [expr {[lindex $m1 0] < 1000}] \ 444 [expr {[lindex $m1 2] == 10}] \ 445 [expr {[lindex $m1 4] > 1000}] \ 446 [expr {[lindex $m1 6] < 100}] \ 447 ] $m1; # interesting only in error case. 448} -match glob -result [list {1 1 1 1} *] 449test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} { 450 set m1 [timerate {} 1000 5]; # max-count wins 451 set m2 [timerate {_nrt_sleep 20} 1 5]; # max-time wins 452 list [lindex $m1 2] [lindex $m2 2] 453} {5 1} 454test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} -body { 455 set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1] 456 list [list \ 457 [expr {[lindex $m1 0] == 0.0}] \ 458 [expr {[lindex $m1 2] == 1}] \ 459 [expr {[lindex $m1 4] == 1000000}] \ 460 [expr {[lindex $m1 6] <= 0.001}] \ 461 ] $m1; # interesting only in error case. 462} -match glob -result [list {1 1 1 1} *] 463test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} { 464 set m1 {set m2 ok} 465 if 1 $m1 466 timerate $m1 1000 10 467 if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop 468} ok 469test cmdMZ-6.12 {Tcl_TimeRateObjCmd: done optimization: nested call of self inside timerate} { 470 set x 0 471 set m1 { 472 if {[incr x] <= 5} { 473 # nested call should return result, so covering that: 474 if {![string is integer -strict [eval $m1]]} {error unexpected} 475 } 476 # increase again (no "continue" from nested call): 477 incr x 478 } 479 list [lindex [timerate $m1 1000 5] 2] $x 480} {5 20} 481 482test cmdMZ-try-1.0 { 483 484 fix for issue 45b9faf103f2 485 486 [try] interaction with local variable names produces segmentation violation 487 488} -body { 489 ::apply {{} { 490 set cmd try 491 $cmd { 492 lindex 5 493 } on ok res {} 494 set res 495 }} 496} -result 5 497 498 499# The tests for Tcl_WhileObjCmd are in while.test 500 501# cleanup 502cleanupTests 503} 504namespace delete ::tcl::test::cmdMZ 505return 506 507# Local Variables: 508# mode: tcl 509# End: 510