1source [file dirname [info script]]/testing.tcl 2 3needs constraint jim 4needs cmd gets tclcompat 5needs cmd array 6 7catch {unset a b} 8test regr-1.1 "Double dereference arrays" { 9 array set a {one ONE two TWO three THREE} 10 array set b {ONE 1 TWO 2 THREE 3} 11 set chan two 12 set b($a($chan)) 13} {2} 14 15# Will assert on exit if the bug exists 16test regr-1.2 "Reference count shared literals" { 17 proc a {} { 18 while {1} {break} 19 } 20 a 21 rename a "" 22 return 1 23} {1} 24 25test regr-1.3 "Invalid for expression" jim { 26 # Crashes with invalid expression 27 catch { 28 for {set i 0} {$i < n} {incr i} { 29 set a(b) $i 30 set a(c) $i 31 break 32 } 33 } 34} 1 35 36test regr-1.4 "format double percent" { 37 format (%d%%) 12 38} {(12%)} 39 40test regr-1.5 "lassign with empty list" { 41 unset -nocomplain a b c 42 lassign {} a b c 43 info exists c 44} {1} 45 46test io-1.1 "Read last line with no newline" { 47 set lines 0 48 set f [open [file dirname [info script]]/testio.in] 49 while {[gets $f buf] >= 0} { 50 incr lines 51 } 52 close $f 53 list $lines 54} {2} 55 56set g1 1 57set g2 2 58array set g3 {4 5 6 7} 59 60proc test_unset {} { 61 test unset-1.1 "Simple var" { 62 set g4 4 63 list [catch {unset g4; info exists g4} msg] $msg 64 } {0 0} 65 66 test unset-1.2 "Simple var" { 67 list [catch {unset g4; info exists g4} msg] $msg 68 } {1 {can't unset "g4": no such variable}} 69 70 test unset-1.3 "Simple var" { 71 list [catch {unset g2; info exists g2} msg] $msg 72 } {1 {can't unset "g2": no such variable}} 73 74 test unset-1.4 "Global via global" { 75 global g1 76 list [catch {unset g1; info exists g1} msg] $msg 77 } {0 0} 78 79 test unset-1.5 "Global error" { 80 list [catch {unset ::g2; info exists ::g2} msg] $msg 81 } {0 0} 82 83 test unset-1.6 "Global array" { 84 list [catch {unset ::g3; info exists ::g3} msg] $msg 85 } {0 0} 86 87 test unset-1.7 "Simple var -nocomplain" { 88 list [catch {unset -nocomplain g2; info exists g2} msg] $msg 89 } {0 0} 90 91 test unset-1.8 "Simple var --" { 92 list [catch {unset -- g2; info exists g2} msg] $msg 93 } {1 {can't unset "g2": no such variable}} 94 95 test unset-1.9 "Simple var -nocomplain --" { 96 set g2 1 97 list [catch {unset -nocomplain -- g2; info exists g2} msg] $msg 98 } {0 0} 99 100 test unset-1.10 "Var named -nocomplain with --" { 101 set -nocomplain 1 102 list [catch {unset -- -nocomplain; info exists -nocomplain} msg] $msg 103 } {0 0} 104 105 test unset-1.11 "Unset no args" { 106 list [catch {unset} msg] $msg 107 } {0 {}} 108} 109 110test_unset 111 112test lrepeat-1.1 "Basic tests" { 113 lrepeat 1 a 114} {a} 115 116test lrepeat-1.2 "Basic tests" { 117 lrepeat 1 a b 118} {a b} 119 120test lrepeat-1.3 "Basic tests" { 121 lrepeat 2 a b 122} {a b a b} 123 124test lrepeat-1.4 "Basic tests" { 125 lrepeat 2 a 126} {a a} 127 128test lrepeat-1.5 "Errors" { 129 catch {lrepeat} 130} {1} 131 132test lrepeat-1.6 "Errors" { 133 lrepeat 1 134} {} 135 136test lrepeat-1.7 "Errors" { 137 lrepeat 0 a b 138} {} 139 140test lrepeat-1.8 "Errors" { 141 catch {lrepeat -10 a} 142} {1} 143 144test lindex-1.1 "Integer" { 145 lindex {a b c} 0 146} a 147 148test lindex-1.2 "Integer" { 149 lindex {a b c} 2 150} c 151 152test lindex-1.3 "Integer" { 153 lindex {a b c} -1 154} {} 155 156test lindex-1.4 "Integer" { 157 lindex {a b c} 4 158} {} 159 160test lindex-1.5 "end" { 161 lindex {a b c} end 162} c 163 164test lindex-1.6 "end" { 165 lindex {a b c} end-1 166} b 167 168test lindex-1.7 "end" { 169 lindex {a b c} end-4 170} {} 171 172test lindex-1.8 "end + " { 173 lindex {a b c} end+1 174} {} 175 176test lindex-1.9 "end + " { 177 lindex {a b c} end+-1 178} b 179 180test lindex-1.10 "end - errors" { 181 catch {lindex {a b c} end-} 182} 1 183 184test lindex-1.11 "end - errors" { 185 catch {lindex {a b c} end-blah} 186} 1 187 188test lindex-1.12 "int+int, int-int" { 189 lindex {a b c} 0+4 190} {} 191 192test lindex-1.13 "int+int, int-int" { 193 lindex {a b c} 3-1 194} c 195 196test lindex-1.14 "int+int, int-int" { 197 lindex {a b c} 1--1 198} c 199 200test lindex-1.15 "int+int, int-int" { 201 set l {a b c} 202 lindex $l [lsearch $l b]-1 203} a 204 205test lindex-1.16 "int+int, int-int" { 206 lindex {a b c} 0+1 207} b 208 209test lindex-1.17 "int+int - errors" { 210 catch {lindex {a b c} 5-blah} 211} 1 212 213test lindex-1.18 "int+int - errors" { 214 catch {lindex {a b c} blah-2} 215} 1 216 217test lindex-1.19 "int+int - errors" { 218 catch {lindex {a b c} 5+blah} 219} 1 220 221test lindex-1.20 "unary plus" { 222 lindex {a b c} +2 223} c 224 225test incr-1.1 "incr unset" { 226 unset -nocomplain a 227 incr a 228 set a 229} 1 230 231test incr-1.2 "incr, incr unset" { 232 incr a 233} 2 234 235test incr-1.3 "incr unset array element" { 236 unset -nocomplain a 237 incr a(2) 238 set a(2) 239} 1 240 241test incr-1.4 "incr array element - shimmering" { 242 set b "$a(2)-test" 243 incr a(2) 244} 2 245 246test catch-1.1 "catch ok" { 247 list [catch {set abc 2} result] $result 248} {0 2} 249 250test catch-1.2 "catch error" { 251 list [catch {error 3} result] $result 252} {1 3} 253 254test catch-1.3 "catch break" { 255 list [catch {break} result] $result 256} {3 {}} 257 258test catch-1.4 "catch -nobreak" { 259 set result {} 260 foreach x {a b c} { 261 lappend result $x 262 # This acts just like break since it won't be caught by catch 263 catch -nobreak {break} tmp 264 } 265 set result 266} {a} 267 268test catch-1.5 "catch -no3" { 269 set result {} 270 foreach x {a b c} { 271 lappend result $x 272 # Same as above, but specify as an integer 273 catch -no3 {break} tmp 274 } 275 set result 276} {a} 277 278test catch-1.6 "catch break" { 279 set result {} 280 foreach x {a b c} { 281 lappend result $x 282 # This does nothing since the break is caught 283 catch {break} tmp 284 } 285 set result 286} {a b c} 287 288 289test catch-1.7 "catch exit" { 290 # Normally exit would not be caught 291 dict get [info returncodes] [catch -exit {exit 5} result] 292} {exit} 293 294test catch-1.8 "catch error has -errorinfo" { 295 set rc [catch {set undefined} msg opts] 296 list $rc [info exists opts(-errorinfo)] 297} {1 1} 298 299test catch-1.9 "catch no error has no -errorinfo" { 300 set rc [catch {set x 1} msg opts] 301 list $rc [info exists opts(-errorinfo)] 302} {0 0} 303 304test return-1.1 "return can rethrow an error" { 305 proc a {} { error "from a" } 306 proc b {} { catch {a} msg opts; return {*}$opts $msg } 307 set rc [catch {b} msg opts] 308 list $rc $msg [llength $opts(-errorinfo)] 309} {1 {from a} 6} 310 311test return-1.2 "error can rethrow an error" { 312 proc a {} { error "from a" } 313 proc b {} { catch {a} msg; error $msg [info stacktrace] } 314 set rc [catch {b} msg opts] 315 list $rc $msg [llength $opts(-errorinfo)] 316} {1 {from a} 9} 317 318test return-1.3 "return can rethrow no error" { 319 proc a {} { return "from a" } 320 proc b {} { catch {a} msg opts; return {*}$opts $msg } 321 set rc [catch {b} msg opts] 322 #list $rc $msg [llength $opts(-errorinfo)] 323 list $rc $msg [info exists opts(-errorinfo)] 324} {0 {from a} 0} 325 326test stringreverse-1.1 "Containing nulls" { 327 string reverse abc\0def 328} "fed\0cba" 329 330test split-1.1 "Split with leading null" { 331 split "\0abc\0def\0" \0 332} {{} abc def {}} 333 334test parsevar-1.1 "Variables should include double colons" { 335 set ::a::b 2 336 set x $::a::b 337 unset ::a::b 338 set x 339} 2 340 341test sharing-1.1 "Problems with ref sharing in arrays: lappend" { 342 set a {a 1 c 2} 343 set b $a 344 lappend b(c) 3 345 set a(c) 346} 2 347 348test sharing-1.2 "Problems with ref sharing in arrays: append" { 349 set a {a 1 c 2} 350 set b $a 351 append b(c) 3 352 set a(c) 353} 2 354 355test sharing-1.3 "Problems with ref sharing in arrays: incr" { 356 set a {a 1 c 2} 357 set b $a 358 incr b(c) 359 set a(c) 360} 2 361 362test sharing-1.4 "Problems with ref sharing in arrays: lset" { 363 set a {a 1 c {2 3}} 364 set b $a 365 lset b(c) 1 x 366 set a(c) 367} {2 3} 368 369test jimexpr-1.1 "integer ** operator" { 370 expr {2 ** 3} 371} 8 372 373test jimexpr-1.2 "integer ** operator" { 374 expr {0 ** 3} 375} 0 376 377test jimexpr-1.3 "integer ** operator" { 378 expr {2 ** 0} 379} 1 380 381test jimexpr-1.4 "integer ** operator" { 382 expr {-2 ** 1} 383} -2 384 385test jimexpr-1.5 "integer ** operator" { 386 expr {3 ** -2} 387} 0 388 389test jimexpr-1.6 "+ command" { 390 + 1 391} 1 392 393test jimexpr-1.7 "+ command" { 394 + 2 3.5 395} 5.5 396 397test jimexpr-1.8 "+ command" { 398 + 2 3 4 -6 399} 3 400 401test jimexpr-1.9 "* command" { 402 * 4 403} 4 404 405test jimexpr-1.10 "* command" { 406 * 4 2 407} 8 408 409test jimexpr-1.11 "* command" { 410 * 4 2 -0.5 411} -4.0 412 413test jimexpr-1.12 "/ command" { 414 / 2 415} 0.5 416 417test jimexpr-1.12 "/ command" { 418 / 0.5 419} 2.0 420 421test jimexpr-1.13 "/ command" { 422 / 12 3 423} 4 424 425test jimexpr-1.14 "/ command" { 426 / 12 3 2.0 427} 2.0 428 429test jimexpr-1.15 "- command" { 430 - 6 431} -6 432 433test jimexpr-1.15 "- command" { 434 - 6.5 435} -6.5 436 437test jimexpr-1.16 "- command" { 438 - 6 3 439} 3 440 441test jimexpr-1.17 "- command" { 442 - 6 3 1.5 443} 1.5 444 445test jimexpr-1.17 "- command" { 446 - 6.5 3 447} 3.5 448 449test jimexpr-2.1 "errors in math commands" { 450 list [catch /] [catch {/ x}] [catch -] [catch {- blah blah}] [catch {- 2.0 blah}] [catch {+ x y}] [catch {* x}] 451} {1 1 1 1 1 1 1} 452 453test jimexpr-2.2 "not var optimisation" { 454 set x [expr 1] 455 set y [expr 0] 456 set z [expr 2.0] 457 list [expr {!$x}] [expr {!$y}] [expr {!$z}] 458} {0 1 0} 459 460test jimexpr-2.3 "expr access unset var" { 461 unset -nocomplain a 462 catch {expr {3 * $a}} 463} 1 464 465test jimexpr-2.4 "expr double as bool" { 466 set x 2 467 if {1.0} { 468 set x 3 469 } 470} 3 471 472# May be supported if support compiled in 473test jimexpr-2.5 "double ** operator" { 474 catch {expr {2.0 ** 3}} result 475 expr {$result in {unsupported 8.0}} 476} 1 477 478test jimexpr-2.6 "exit in expression" { 479 # The inner 'exit 0' should propagate through the if to 480 # the outer catch 481 catch -exit { 482 set x 1 483 if {[catch {exit 0}] == 1} { 484 set x 2 485 } else { 486 set x 3 487 } 488 } 489} 6 490 491# This one is for test coverage of an unusual case 492test jimobj-1.1 "duplicate obj with no dupIntRepProc" { 493 proc "x x" {} { return 2 } 494 set a "x x" 495 # force it to be a command object 496 set b [$a] 497 # A second reference 498 set c $a 499 # Now force it to be duplicated 500 lset a 1 x 501 # force the duplicate object it to be a command object again 502 set b [$a] 503 # And get the string rep 504 set x "y $a" 505} "y x x" 506 507test jimobj-1.2 "cooerced double to int" { 508 set x 3 509 # cooerce to a double 510 expr {4.5 + $x} 511 # Now get the int rep 512 incr x 513} 4 514 515test jimobj-1.3 "cooerced double to double" { 516 set x 3 517 # cooerce to a double 518 expr {4.5 + $x} 519 # Now use as a double 520 expr {1.5 + $x} 521} 4.5 522 523test jimobj-1.4 "incr dict sugar" { 524 unset -nocomplain a 525 set a(3) 3 526 incr a(3) 527 list $a(3) $a 528} {4 {3 4}} 529 530test jim-badvar-1.1 "invalid variable name" { 531 set x b\0c 532 catch {set $x 5} 533} 1 534 535test jim-badvar-1.2 "incr invalid variable name" { 536 set x b\0c 537 catch {incr $x} 538} 1 539 540test lset-1.1 "lset with bad var" { 541 catch {lset badvar 1 x} 542} 1 543 544test dict-1.1 "dict to string" { 545 set a [dict create abc \\ def \"] 546 set x x$a 547 # The order of keys in the dictionary is random 548 if {$x eq "xabc \\\\ def {\"}" || $x eq "xdef {\"} abc \\\\"} { 549 return ok 550 } else { 551 return "failed: \"$x\"" 552 } 553} ok 554 555test channels-1.1 {info channels} { 556 lsort [info channels] 557} {stderr stdin stdout} 558 559test lmap-1.1 {lmap} { 560 lmap p {1 2 3} {incr p} 561} {2 3 4} 562 563test exprerr-1.1 {Error message with bad expr} { 564 catch {expr {5 ||}} msg 565 set msg 566} {syntax error in expression "5 ||": premature end of expression} 567 568test eval-list-1.1 {Lost string rep with list} { 569 set x {set y 1; incr y} 570 # Convert to list rep internally 571 lindex $x 4 572 # But make sure we don't lost the original string rep 573 list [catch $x] $y 574} {0 2} 575 576test info-statics-1.1 {info statics commands} { 577 set x 1 578 proc a {} {x {y 2}} {} 579 lsort [info statics a] 580} {1 2 x y} 581 582testreport 583