tests/misc.test

   1 source [file dirname [info script]]/testing.tcl
   2
   3 needs constraint jim
   4 needs cmd gets tclcompat
   5 needs cmd array
   6
   7 catch {unset a b}
   8 test 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
  16 test 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
  25 test 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
  36 test regr-1.4 "format double percent" {
  37         format (%d%%) 12
  38 } {(12%)}
  39
  40 test 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
  46 test 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
  56 set g1 1
  57 set g2 2
  58 array set g3 {4 5 6 7}
  59
  60 proc 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
 110 test_unset
 111
 112 test lrepeat-1.1 "Basic tests" {
 113         lrepeat 1 a
 114 } {a}
 115
 116 test lrepeat-1.2 "Basic tests" {
 117         lrepeat 1 a b
 118 } {a b}
 119
 120 test lrepeat-1.3 "Basic tests" {
 121         lrepeat 2 a b
 122 } {a b a b}
 123
 124 test lrepeat-1.4 "Basic tests" {
 125         lrepeat 2 a
 126 } {a a}
 127
 128 test lrepeat-1.5 "Errors" {
 129         catch {lrepeat}
 130 } {1}
 131
 132 test lrepeat-1.6 "Errors" {
 133         lrepeat 1
 134 } {}
 135
 136 test lrepeat-1.7 "Errors" {
 137         lrepeat 0 a b
 138 } {}
 139
 140 test lrepeat-1.8 "Errors" {
 141         catch {lrepeat -10 a}
 142 } {1}
 143
 144 test lindex-1.1 "Integer" {
 145         lindex {a b c} 0
 146 } a
 147
 148 test lindex-1.2 "Integer" {
 149         lindex {a b c} 2
 150 } c
 151
 152 test lindex-1.3 "Integer" {
 153         lindex {a b c} -1
 154 } {}
 155
 156 test lindex-1.4 "Integer" {
 157         lindex {a b c} 4
 158 } {}
 159
 160 test lindex-1.5 "end" {
 161         lindex {a b c} end
 162 } c
 163
 164 test lindex-1.6 "end" {
 165         lindex {a b c} end-1
 166 } b
 167
 168 test lindex-1.7 "end" {
 169         lindex {a b c} end-4
 170 } {}
 171
 172 test lindex-1.8 "end + " {
 173         lindex {a b c} end+1
 174 } {}
 175
 176 test lindex-1.9 "end + " {
 177         lindex {a b c} end+-1
 178 } b
 179
 180 test lindex-1.10 "end - errors" {
 181         catch {lindex {a b c} end-}
 182 } 1
 183
 184 test lindex-1.11 "end - errors" {
 185         catch {lindex {a b c} end-blah}
 186 } 1
 187
 188 test lindex-1.12 "int+int, int-int" {
 189         lindex {a b c} 0+4
 190 } {}
 191
 192 test lindex-1.13 "int+int, int-int" {
 193         lindex {a b c} 3-1
 194 } c
 195
 196 test lindex-1.14 "int+int, int-int" {
 197         lindex {a b c} 1--1
 198 } c
 199
 200 test lindex-1.15 "int+int, int-int" {
 201         set l {a b c}
 202         lindex $l [lsearch $l b]-1
 203 } a
 204
 205 test lindex-1.16 "int+int, int-int" {
 206         lindex {a b c} 0+1
 207 } b
 208
 209 test lindex-1.17 "int+int - errors" {
 210         catch {lindex {a b c} 5-blah}
 211 } 1
 212
 213 test lindex-1.18 "int+int - errors" {
 214         catch {lindex {a b c} blah-2}
 215 } 1
 216
 217 test lindex-1.19 "int+int - errors" {
 218         catch {lindex {a b c} 5+blah}
 219 } 1
 220
 221 test lindex-1.20 "unary plus" {
 222         lindex {a b c} +2
 223 } c
 224
 225 test incr-1.1 "incr unset" {
 226         unset -nocomplain a
 227         incr a
 228         set a
 229 } 1
 230
 231 test incr-1.2 "incr, incr unset" {
 232         incr a
 233 } 2
 234
 235 test incr-1.3 "incr unset array element" {
 236         unset -nocomplain a
 237         incr a(2)
 238         set a(2)
 239 } 1
 240
 241 test incr-1.4 "incr array element - shimmering" {
 242         set b "$a(2)-test"
 243         incr a(2)
 244 } 2
 245
 246 test catch-1.1 "catch ok" {
 247         list [catch {set abc 2} result] $result
 248 } {0 2}
 249
 250 test catch-1.2 "catch error" {
 251         list [catch {error 3} result] $result
 252 } {1 3}
 253
 254 test catch-1.3 "catch break" {
 255         list [catch {break} result] $result
 256 } {3 {}}
 257
 258 test 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
 268 test 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
 278 test 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
 289 test 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
 294 test 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
 299 test 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
 304 test 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} 9}
 310
 311 test 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
 318 test 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
 326 test stringreverse-1.1 "Containing nulls" {
 327         string reverse abc\0def
 328 } "fed\0cba"
 329
 330 test split-1.1 "Split with leading null" {
 331         split "\0abc\0def\0" \0
 332 } {{} abc def {}}
 333
 334 test 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
 341 test 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
 348 test 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
 355 test 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
 362 test 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
 369 test jimexpr-1.1 "integer ** operator" {
 370     expr {2 ** 3}
 371 } 8
 372
 373 test jimexpr-1.2 "integer ** operator" {
 374     expr {0 ** 3}
 375 } 0
 376
 377 test jimexpr-1.3 "integer ** operator" {
 378     expr {2 ** 0}
 379 } 1
 380
 381 test jimexpr-1.4 "integer ** operator" {
 382     expr {-2 ** 1}
 383 } -2
 384
 385 test jimexpr-1.5 "integer ** operator" {
 386     expr {3 ** -2}
 387 } 0
 388
 389 test jimexpr-1.6 "+ command" {
 390     + 1
 391 } 1
 392
 393 test jimexpr-1.7 "+ command" {
 394     + 2 3.5
 395 } 5.5
 396
 397 test jimexpr-1.8 "+ command" {
 398     + 2 3 4 -6
 399 } 3
 400
 401 test jimexpr-1.9 "* command" {
 402     * 4
 403 } 4
 404
 405 test jimexpr-1.10 "* command" {
 406     * 4 2
 407 } 8
 408
 409 test jimexpr-1.11 "* command" {
 410     * 4 2 -0.5
 411 } -4.0
 412
 413 test jimexpr-1.12 "/ command" {
 414     / 2
 415 } 0.5
 416
 417 test jimexpr-1.12 "/ command" {
 418     / 0.5
 419 } 2.0
 420
 421 test jimexpr-1.13 "/ command" {
 422     / 12 3
 423 } 4
 424
 425 test jimexpr-1.14 "/ command" {
 426     / 12 3 2.0
 427 } 2.0
 428
 429 test jimexpr-1.15 "- command" {
 430     - 6
 431 } -6
 432
 433 test jimexpr-1.15 "- command" {
 434     - 6.5
 435 } -6.5
 436
 437 test jimexpr-1.16 "- command" {
 438     - 6 3
 439 } 3
 440
 441 test jimexpr-1.17 "- command" {
 442     - 6 3 1.5
 443 } 1.5
 444
 445 test jimexpr-1.17 "- command" {
 446     - 6.5 3
 447 } 3.5
 448
 449 test 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
 453 test 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
 460 test jimexpr-2.3 "expr access unset var" {
 461         unset -nocomplain a
 462         catch {expr {3 * $a}}
 463 } 1
 464
 465 test 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
 473 test jimexpr-2.5 "double ** operator" {
 474     catch {expr {2.0 ** 3}} result
 475     expr {$result in {unsupported 8.0}}
 476 } 1
 477
 478 test 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
 492 test 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
 507 test 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
 515 test 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
 523 test 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
 530 test jim-badvar-1.1 "invalid variable name" {
 531         set x b\0c
 532         catch {set $x 5}
 533 } 1
 534
 535 test jim-badvar-1.2 "incr invalid variable name" {
 536         set x b\0c
 537         catch {incr $x}
 538 } 1
 539
 540 test lset-1.1 "lset with bad var" {
 541         catch {lset badvar 1 x}
 542 } 1
 543
 544 test 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
 555 test channels-1.1 {info channels} {
 556         lsort [info channels]
 557 } {stderr stdin stdout}
 558
 559 test lmap-1.1 {lmap} {
 560         lmap p {1 2 3} {incr p}
 561 } {2 3 4}
 562
 563 test 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
 568 test 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
 576 test 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
 582 testreport