588 lines
11 KiB
Plaintext
588 lines
11 KiB
Plaintext
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" {
|
|
proc a {} { error "from a" }
|
|
proc b {} { catch {a} msg opts; return {*}$opts $msg }
|
|
set rc [catch {b} msg opts]
|
|
list $rc $msg [llength $opts(-errorinfo)]
|
|
} {1 {from a} 9}
|
|
|
|
test return-1.2 "error can rethrow an error" {
|
|
proc a {} { error "from a" }
|
|
proc b {} { catch {a} msg; error $msg [info stacktrace] }
|
|
set rc [catch {b} msg opts]
|
|
list $rc $msg [llength $opts(-errorinfo)]
|
|
} {1 {from a} 9}
|
|
|
|
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 [llength $opts(-errorinfo)]
|
|
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}} {}
|
|
lsort [info statics a]
|
|
} {1 2 x y}
|
|
|
|
testreport
|