source [file dirname [info script]]/testing.tcl needs constraint jim needs cmd gets tclcompat needs cmd array catch {unset a b} test regr-1.1 "Double dereference arrays" { array set a {one ONE two TWO three THREE} array set b {ONE 1 TWO 2 THREE 3} set chan two set b($a($chan)) } {2} # Will assert on exit if the bug exists test regr-1.2 "Reference count shared literals" { proc a {} { while {1} {break} } a rename a "" return 1 } {1} test regr-1.3 "Invalid for expression" jim { # Crashes with invalid expression catch { for {set i 0} {$i < n} {incr i} { set a(b) $i set a(c) $i break } } } 1 test regr-1.4 "format double percent" { format (%d%%) 12 } {(12%)} test regr-1.5 "lassign with empty list" { unset -nocomplain a b c lassign {} a b c info exists c } {1} test io-1.1 "Read last line with no newline" { set lines 0 set f [open [file dirname [info script]]/testio.in] while {[gets $f buf] >= 0} { incr lines } close $f list $lines } {2} set g1 1 set g2 2 array set g3 {4 5 6 7} proc test_unset {} { test unset-1.1 "Simple var" { set g4 4 list [catch {unset g4; info exists g4} msg] $msg } {0 0} test unset-1.2 "Simple var" { list [catch {unset g4; info exists g4} msg] $msg } {1 {can't unset "g4": no such variable}} test unset-1.3 "Simple var" { list [catch {unset g2; info exists g2} msg] $msg } {1 {can't unset "g2": no such variable}} test unset-1.4 "Global via global" { global g1 list [catch {unset g1; info exists g1} msg] $msg } {0 0} test unset-1.5 "Global error" { list [catch {unset ::g2; info exists ::g2} msg] $msg } {0 0} test unset-1.6 "Global array" { list [catch {unset ::g3; info exists ::g3} msg] $msg } {0 0} test unset-1.7 "Simple var -nocomplain" { list [catch {unset -nocomplain g2; info exists g2} msg] $msg } {0 0} test unset-1.8 "Simple var --" { list [catch {unset -- g2; info exists g2} msg] $msg } {1 {can't unset "g2": no such variable}} test unset-1.9 "Simple var -nocomplain --" { set g2 1 list [catch {unset -nocomplain -- g2; info exists g2} msg] $msg } {0 0} test unset-1.10 "Var named -nocomplain with --" { set -nocomplain 1 list [catch {unset -- -nocomplain; info exists -nocomplain} msg] $msg } {0 0} test unset-1.11 "Unset no args" { list [catch {unset} msg] $msg } {0 {}} } test_unset test lrepeat-1.1 "Basic tests" { lrepeat 1 a } {a} test lrepeat-1.2 "Basic tests" { lrepeat 1 a b } {a b} test lrepeat-1.3 "Basic tests" { lrepeat 2 a b } {a b a b} test lrepeat-1.4 "Basic tests" { lrepeat 2 a } {a a} test lrepeat-1.5 "Errors" { catch {lrepeat} } {1} test lrepeat-1.6 "Errors" { lrepeat 1 } {} test lrepeat-1.7 "Errors" { lrepeat 0 a b } {} test lrepeat-1.8 "Errors" { catch {lrepeat -10 a} } {1} test lindex-1.1 "Integer" { lindex {a b c} 0 } a test lindex-1.2 "Integer" { lindex {a b c} 2 } c test lindex-1.3 "Integer" { lindex {a b c} -1 } {} test lindex-1.4 "Integer" { lindex {a b c} 4 } {} test lindex-1.5 "end" { lindex {a b c} end } c test lindex-1.6 "end" { lindex {a b c} end-1 } b test lindex-1.7 "end" { lindex {a b c} end-4 } {} test lindex-1.8 "end + " { lindex {a b c} end+1 } {} test lindex-1.9 "end + " { lindex {a b c} end+-1 } b test lindex-1.10 "end - errors" { catch {lindex {a b c} end-} } 1 test lindex-1.11 "end - errors" { catch {lindex {a b c} end-blah} } 1 test lindex-1.12 "int+int, int-int" { lindex {a b c} 0+4 } {} test lindex-1.13 "int+int, int-int" { lindex {a b c} 3-1 } c test lindex-1.14 "int+int, int-int" { lindex {a b c} 1--1 } c test lindex-1.15 "int+int, int-int" { set l {a b c} lindex $l [lsearch $l b]-1 } a test lindex-1.16 "int+int, int-int" { lindex {a b c} 0+1 } b test lindex-1.17 "int+int - errors" { catch {lindex {a b c} 5-blah} } 1 test lindex-1.18 "int+int - errors" { catch {lindex {a b c} blah-2} } 1 test lindex-1.19 "int+int - errors" { catch {lindex {a b c} 5+blah} } 1 test lindex-1.20 "unary plus" { lindex {a b c} +2 } c test incr-1.1 "incr unset" { unset -nocomplain a incr a set a } 1 test incr-1.2 "incr, incr unset" { incr a } 2 test incr-1.3 "incr unset array element" { unset -nocomplain a incr a(2) set a(2) } 1 test incr-1.4 "incr array element - shimmering" { set b "$a(2)-test" incr a(2) } 2 test catch-1.1 "catch ok" { list [catch {set abc 2} result] $result } {0 2} test catch-1.2 "catch error" { list [catch {error 3} result] $result } {1 3} test catch-1.3 "catch break" { list [catch {break} result] $result } {3 {}} test catch-1.4 "catch -nobreak" { set result {} foreach x {a b c} { lappend result $x # This acts just like break since it won't be caught by catch catch -nobreak {break} tmp } set result } {a} test catch-1.5 "catch -no3" { set result {} foreach x {a b c} { lappend result $x # Same as above, but specify as an integer catch -no3 {break} tmp } set result } {a} test catch-1.6 "catch break" { set result {} foreach x {a b c} { lappend result $x # This does nothing since the break is caught catch {break} tmp } set result } {a b c} test catch-1.7 "catch exit" { # Normally exit would not be caught list [dict get [info returncodes] [catch -exit {exit 5} result]] $result } {exit 5} test catch-1.8 "catch error has -errorinfo" { set rc [catch {set undefined} msg opts] list $rc [info exists opts(-errorinfo)] } {1 1} test catch-1.9 "catch no error has no -errorinfo" { set rc [catch {set x 1} msg opts] list $rc [info exists opts(-errorinfo)] } {0 0} test return-1.1 {return can rethrow an error} -body { proc a {} { error "from a" } proc b {} { catch {a} msg opts; return {*}$opts $msg } set rc [catch {b} msg opts] list $rc $msg [basename-stacktrace $opts(-errorinfo)] } -result {1 {from a} {a misc.test 305 {error {from a}} b misc.test 306 a test misc.test 307 b {} misc.test 304 test\ return-1.1\ \{retu...}} test return-1.2 {error can rethrow an error} -body { proc a {} { error "from a" } proc b {} { catch {a} msg; error $msg [info stacktrace] } set rc [catch {b} msg opts] list $rc $msg [basename-stacktrace $opts(-errorinfo)] } -result {1 {from a} {a misc.test 312 {error {from a}} b misc.test 313 a test misc.test 314 b {} misc.test 311 test\ return-1.2\ \{erro...}} test return-1.3 "return can rethrow no error" { proc a {} { return "from a" } proc b {} { catch {a} msg opts; return {*}$opts $msg } set rc [catch {b} msg opts] list $rc $msg [info exists opts(-errorinfo)] } {0 {from a} 0} test stringreverse-1.1 "Containing nulls" { string reverse abc\0def } "fed\0cba" test split-1.1 "Split with leading null" { split "\0abc\0def\0" \0 } {{} abc def {}} test parsevar-1.1 "Variables should include double colons" { set ::a::b 2 set x $::a::b unset ::a::b set x } 2 test sharing-1.1 "Problems with ref sharing in arrays: lappend" { set a {a 1 c 2} set b $a lappend b(c) 3 set a(c) } 2 test sharing-1.2 "Problems with ref sharing in arrays: append" { set a {a 1 c 2} set b $a append b(c) 3 set a(c) } 2 test sharing-1.3 "Problems with ref sharing in arrays: incr" { set a {a 1 c 2} set b $a incr b(c) set a(c) } 2 test sharing-1.4 "Problems with ref sharing in arrays: lset" { set a {a 1 c {2 3}} set b $a lset b(c) 1 x set a(c) } {2 3} test jimexpr-1.1 "integer ** operator" { expr {2 ** 3} } 8 test jimexpr-1.2 "integer ** operator" { expr {0 ** 3} } 0 test jimexpr-1.3 "integer ** operator" { expr {2 ** 0} } 1 test jimexpr-1.4 "integer ** operator" { expr {-2 ** 1} } -2 test jimexpr-1.5 "integer ** operator" { expr {3 ** -2} } 0 test jimexpr-1.6 "+ command" { + 1 } 1 test jimexpr-1.7 "+ command" { + 2 3.5 } 5.5 test jimexpr-1.8 "+ command" { + 2 3 4 -6 } 3 test jimexpr-1.9 "* command" { * 4 } 4 test jimexpr-1.10 "* command" { * 4 2 } 8 test jimexpr-1.11 "* command" { * 4 2 -0.5 } -4.0 test jimexpr-1.12 "/ command" { / 2 } 0.5 test jimexpr-1.12 "/ command" { / 0.5 } 2.0 test jimexpr-1.13 "/ command" { / 12 3 } 4 test jimexpr-1.14 "/ command" { / 12 3 2.0 } 2.0 test jimexpr-1.15 "- command" { - 6 } -6 test jimexpr-1.15 "- command" { - 6.5 } -6.5 test jimexpr-1.16 "- command" { - 6 3 } 3 test jimexpr-1.17 "- command" { - 6 3 1.5 } 1.5 test jimexpr-1.17 "- command" { - 6.5 3 } 3.5 test jimexpr-2.1 "errors in math commands" { list [catch /] [catch {/ x}] [catch -] [catch {- blah blah}] [catch {- 2.0 blah}] [catch {+ x y}] [catch {* x}] } {1 1 1 1 1 1 1} test jimexpr-2.2 "not var optimisation" { set x [expr 1] set y [expr 0] set z [expr 2.0] list [expr {!$x}] [expr {!$y}] [expr {!$z}] } {0 1 0} test jimexpr-2.3 "expr access unset var" { unset -nocomplain a catch {expr {3 * $a}} } 1 test jimexpr-2.4 "expr double as bool" { set x 2 if {1.0} { set x 3 } } 3 # May be supported if support compiled in test jimexpr-2.5 "double ** operator" { catch {expr {2.0 ** 3}} result expr {$result in {unsupported 8.0}} } 1 test jimexpr-2.6 "exit in expression" { # The inner 'exit 0' should propagate through the if to # the outer catch catch -exit { set x 1 if {[catch {exit 0}] == 1} { set x 2 } else { set x 3 } } } 6 # This one is for test coverage of an unusual case test jimobj-1.1 "duplicate obj with no dupIntRepProc" { proc "x x" {} { return 2 } set a "x x" # force it to be a command object set b [$a] # A second reference set c $a # Now force it to be duplicated lset a 1 x # force the duplicate object it to be a command object again set b [$a] # And get the string rep set x "y $a" } "y x x" test jimobj-1.2 "cooerced double to int" { set x 3 # cooerce to a double expr {4.5 + $x} # Now get the int rep incr x } 4 test jimobj-1.3 "cooerced double to double" { set x 3 # cooerce to a double expr {4.5 + $x} # Now use as a double expr {1.5 + $x} } 4.5 test jimobj-1.4 "incr dict sugar" { unset -nocomplain a set a(3) 3 incr a(3) list $a(3) $a } {4 {3 4}} test jim-badvar-1.1 "variable name with embedded null" { set x b\0c set $x 5 } 5 test jim-badvar-1.2 "incr variable name with embedded null" { set x b\0c incr $x } 6 test lset-1.1 "lset with bad var" { catch {lset badvar 1 x} } 1 test lset-1.2 "lset error message" { catch lset msg set msg } {wrong # args: should be "lset listVar ?index ...? value"} test dict-1.1 "dict to string" { set a [dict create abc \\ def \"] set x x$a # The order of keys in the dictionary is random if {$x eq "xabc \\\\ def {\"}" || $x eq "xdef {\"} abc \\\\"} { return ok } else { return "failed: \"$x\"" } } ok test channels-1.1 {info channels} { lsort [info channels] } {stderr stdin stdout} test lmap-1.1 {lmap} { lmap p {1 2 3} {incr p} } {2 3 4} test exprerr-1.1 {Error message with bad expr} { catch {expr {5 ||}} msg set msg } {syntax error in expression "5 ||": premature end of expression} test eval-list-1.1 {Lost string rep with list} { set x {set y 1; incr y} # Convert to list rep internally lindex $x 4 # But make sure we don't lost the original string rep list [catch $x] $y } {0 2} test info-statics-1.1 {info statics commands} { set x 1 proc a {} {x {y 2}} { incr x; incr y} a # Returns the dict of the current static variables info statics a } {x 2 y 3} testreport