diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/breakcont.test (renamed from tests/breakcontinue.test) | 0 | ||||
| -rw-r--r-- | tests/event.test | 23 | ||||
| -rw-r--r-- | tests/expr.test | 7 | ||||
| -rw-r--r-- | tests/forget-test.tcl | 3 | ||||
| -rw-r--r-- | tests/io.test | 26 | ||||
| -rw-r--r-- | tests/jimsh.test | 30 | ||||
| -rw-r--r-- | tests/json.test | 26 | ||||
| -rw-r--r-- | tests/lsort.test | 129 | ||||
| -rw-r--r-- | tests/package.test | 12 | ||||
| -rw-r--r-- | tests/try.test | 9 |
10 files changed, 227 insertions, 38 deletions
diff --git a/tests/breakcontinue.test b/tests/breakcont.test index ddf9438..ddf9438 100644 --- a/tests/breakcontinue.test +++ b/tests/breakcont.test diff --git a/tests/event.test b/tests/event.test index 4f0b3c7..a81128e 100644 --- a/tests/event.test +++ b/tests/event.test @@ -78,18 +78,24 @@ test event-7.4 {bgerror throws an error} -constraints jim -body { } after 0 {error err1} update - } + } 2>gorp.err + set f [open gorp.err] + set err [read $f] + close $f + set err } -result {stdin:3: Error: inside bgerror Traceback (most recent call last): File "stdin", line 6 bgerror err1 File "stdin", line 3, in bgerror - error {inside bgerror}} + error {inside bgerror} +} -cleanup { + file delete gorp.err +} # end of bgerror tests catch {rename bgerror {}} - test event-10.1 {Tcl_Exit procedure} exec { set cmd [list exec [info nameofexecutable] "<<exit 3"] list [catch $cmd msg] [lindex $errorCode 0] \ @@ -170,9 +176,10 @@ test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {s list $x $y $z } {3 3 done} -test event-12.1 {Tcl_UpdateCmd procedure} { - list [catch {update a b} msg] $msg -} {1 {wrong # args: should be "update ?idletasks?"}} +test event-12.1 {Tcl_UpdateCmd procedure - usage} -body { + update a b +} -returnCodes error -result {wrong # args: should be "update ?idletasks?"} + test event-12.3 {Tcl_UpdateCmd procedure} { foreach i [after info] { after cancel $i @@ -211,8 +218,8 @@ test event-13.1 "vwait/signal" signal { signal handle ALRM list [catch -signal { alarm 0.1 - # This is just to prevent the vwait from exiting immediately - stdin readable { format test } + # prevent the vwait from exiting immediately + after 1000 { } vwait forever } msg] $msg } {5 SIGALRM} diff --git a/tests/expr.test b/tests/expr.test index 7e26c0a..bc52afd 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -154,5 +154,12 @@ test expr-5.3 {boolean in expression} { expr {true ? 4 : 5} } {4} +test expr-6.1 "Unary negation on boolean - should return error" -body { + expr {-true} +} -returnCodes error -result {can't use non-numeric string as operand of "-"} + +test expr-6.2 "Unary plus on boolean - should return error" -body { + expr {+true} +} -returnCodes error -result {can't use non-numeric string as operand of "+"} testreport diff --git a/tests/forget-test.tcl b/tests/forget-test.tcl new file mode 100644 index 0000000..8d4289b --- /dev/null +++ b/tests/forget-test.tcl @@ -0,0 +1,3 @@ +# This is a dummy package used for testing package forget + +set forgotten 1 diff --git a/tests/io.test b/tests/io.test new file mode 100644 index 0000000..1b06439 --- /dev/null +++ b/tests/io.test @@ -0,0 +1,26 @@ +source [file dirname [info script]]/testing.tcl + +# This is a proxy for tcl || tclcompat +constraint cmd fconfigure + +# The tests in this file are intended to test Tcl-compatible I/O features + +test io-1.1 {translation binary} -body { + # write a file via stdout in binary mode + # This will always work on Unix + set script { + fconfigure stdout -translation binary + puts line1 + puts line2 + } + exec [info nameofexecutable] << $script >binary.out + # Read it back in binary mode + set f [open binary.out rb] + set buf [read $f] + close $f + set buf +} -cleanup { + file delete binary.out +} -result "line1\nline2\n" + +testreport diff --git a/tests/jimsh.test b/tests/jimsh.test index a02ed9f..8faf2d8 100644 --- a/tests/jimsh.test +++ b/tests/jimsh.test @@ -28,29 +28,17 @@ test jimsh-1.5 {jimsh --version} { test jimsh-1.6 {jimsh -e with error} -body { exec [info nameofexecutable] -e blah -} -returnCodes error -result {invalid command name "blah"} +} -returnCodes error -match glob -result {invalid command name "blah"*} -test jimsh-1.7 {jimsh prompt} -body { - exec [info nameofexecutable] << "set x 3\nincr x\nexit \$x\n" -} -returnCodes error -match glob -result {Welcome to Jim version * -. 3 -. 4 -. } +test jimsh-1.7 {jimsh exit code} -body { + set script "set x 3\nincr x\nexit \$x\n" + set rc [catch {exec [info nameofexecutable] << $script} msg opts] + lassign [dict get $opts -errorcode] status pid exitcode + list $rc $status $exitcode +} -result {1 CHILDSTATUS 4} -test jimsh-1.8 {jimsh prompt - error} -body { +test jimsh-1.8 {jimsh error} -body { exec [info nameofexecutable] << "blah\n" -} -match glob -result {Welcome to Jim version * -. invalid command name "blah" -\[error\] . } - -test jimsh-1.9 {jimsh prompt - error} -body { - exec [info nameofexecutable] << "throw 99\n" -} -match glob -result {Welcome to Jim version * -. \[99\] . } - -test jimsh-1.10 {jimsh prompt - continuation} -body { - exec [info nameofexecutable] << "set x {\nabc\n}\n" -} -match glob -result "Welcome to Jim version *\n. {> {> \nabc\n\n. " - +} -returnCodes error -match glob -result {stdin:1: Error: invalid command name "blah"*} testreport diff --git a/tests/json.test b/tests/json.test index ed73401..09c002c 100644 --- a/tests/json.test +++ b/tests/json.test @@ -3,7 +3,8 @@ source [file dirname [info script]]/testing.tcl needs cmd json::decode json needs cmd json::encode json -set json { +# Create a json string as though it was read from data.json +set json [info source { { "fossil":"9c65b5432e4aeecf3556e5550c338ce93fd861cc", "timestamp":1435827337, @@ -24,7 +25,7 @@ set json { "tags":["trunk"] }] } -}} +}} data.json 1] test json-decode-001 {top level keys} { lsort [dict keys [json::decode $json]] @@ -60,6 +61,7 @@ test json-decode-012 {default null value} { } {null} test json-decode-1.1 {Number forms} { + # Note that this is not strictly correct JSON, but is usable in practice json::decode {[ 1, 2, 3.0, 4, Infinity, NaN, -Infinity, -0.0, 1e5, -1e-5 ]} } {1 2 3.0 4 Inf NaN -Inf -0.0 1e5 -1e-5} @@ -80,15 +82,15 @@ test json-2.4 {schema tests} { } {obj a num b num} test json-2.5 {schema tests} { - lindex [json::decode -schema {[1, 2, {a:"b", c:false}, "hello"]}] 1 + lindex [json::decode -schema {[1, 2, {"a":"b", "c":false}, "hello"]}] 1 } {mixed num num {obj a str c bool} str} test json-2.6 {schema tests} { - lindex [json::decode -schema {[1, 2, {a:["b", 1, true, Infinity]}]}] 1 + lindex [json::decode -schema {[1, 2, {"a":["b", 1, true, Infinity]}]}] 1 } {mixed num num {obj a {mixed str num bool num}}} test json-2.7 {schema tests} { - lindex [json::decode -schema {[1, 2, {a:["b", 1, true, ["d", "e", "f"]]}]}] 1 + lindex [json::decode -schema {[1, 2, {"a":["b", 1, true, ["d", "e", "f"]]}]}] 1 } {mixed num num {obj a {mixed str num bool {list str}}}} test json-2.8 {schema tests} { @@ -96,10 +98,9 @@ test json-2.8 {schema tests} { } {mixed num num bool bool} test json-2.9 {schema tests} { - lindex [json::decode -schema {[{a:1},{b:2}]}] 1 + lindex [json::decode -schema {[{"a":1},{"b":2}]}] 1 } {mixed {obj a num} {obj b num}} - test json-3.1 {-index array} { json::decode -index \ {[null, 1, 2, true, false, "hello"]} @@ -122,6 +123,17 @@ test json-3.4 {-index array with -schema 2} { } "{outer {0 {key value} 1 {key2 value2}}}\ {obj outer {mixed {obj key str} {obj key2 str}}}" +test json-4.1 {source info preserved} -body { + info source [dict get [json::decode $json] fossil] +} -result {data.json 3} + +test json-4.2 {source info preserved} -body { + info source [dict get [json::decode $json] procTimeUs] +} -result {data.json 6} + +test json-4.3 {source info preserved} -body { + info source [dict get [lindex [dict get [json::decode $json] payload timeline] 0] comment] +} -result {data.json 17} unset -nocomplain json diff --git a/tests/lsort.test b/tests/lsort.test index 5297568..f60bc06 100644 --- a/tests/lsort.test +++ b/tests/lsort.test @@ -17,7 +17,7 @@ test lsort-1.1 {Tcl_LsortObjCmd procedure} jim { } {1 {wrong # args: should be "lsort ?options? list"}} test lsort-1.2 {Tcl_LsortObjCmd procedure} jim { list [catch {lsort -foo {1 3 2 5}} msg] $msg -} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -increasing, -index, -integer, -nocase, -real, -stride, or -unique}} +} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -integer, -nocase, -real, -stride, or -unique}} test lsort-1.3 {Tcl_LsortObjCmd procedure, default options} { lsort {d e c b a \{ d35 d300} } {a b c d d300 d35 e \{} @@ -207,6 +207,12 @@ test lsort-5.1 "Sort case insensitive" { lsort -nocase {ba aB aa ce} } {aa aB ba ce} +test cmdIL-1.8 {Tcl_LsortObjCmd procedure, -dictionary option} { + lsort -dictionary {d e c b a d35 d300} +} {a b c d d35 d300 e} +test cmdIL-1.9 {Tcl_LsortObjCmd procedure, -dictionary option} { + lsort -dictionary {1k 0k 10k} +} {0k 1k 10k} test cmdIL-1.30 {Tcl_LsortObjCmd procedure, -stride option} { lsort -stride 2 {f e d c b a} } {b a d c f e} @@ -237,5 +243,126 @@ test cmdIL-1.41 {lsort -stride and -index} -body { test cmdIL-1.42 {lsort -stride and-index} -body { lsort -stride 2 -index -1-1 {a 2 b 1} } -returnCodes error -result {index "-1-1" out of range} +test cmdIL-3.8 {SortCompare procedure, -dictionary option} { + lsort -dictionary {d e c b a d35 d300 100 20} +} {20 100 a b c d d35 d300 e} + +test cmdIL-4.1 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a003b a03b} +} {a03b a003b} +test cmdIL-4.2 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a3b a03b} +} {a3b a03b} +# This test fails in Jim because we don't bother falling back to a secondary +# sort on case if the primary sort (with leading zeros) is equal. +test cmdIL-4.3 {DictionaryCompare procedure, numerics, leading zeros} tcl { + lsort -dictionary {a3b A03b} +} {A03b a3b} +test cmdIL-4.4 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {a3b a03B} +} {a3b a03B} +test cmdIL-4.5 {DictionaryCompare procedure, numerics, leading zeros} { + lsort -dictionary {00000 000} +} {000 00000} +test cmdIL-4.6 {DictionaryCompare procedure, numerics, different lengths} { + lsort -dictionary {a321b a03210b} +} {a321b a03210b} +test cmdIL-4.7 {DictionaryCompare procedure, numerics, different lengths} { + lsort -dictionary {a03210b a321b} +} {a321b a03210b} +test cmdIL-4.8 {DictionaryCompare procedure, numerics} { + lsort -dictionary {48 6a 18b 22a 21aa 35 36} +} {6a 18b 21aa 22a 35 36 48} +test cmdIL-4.9 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a123x a123b} +} {a123b a123x} +test cmdIL-4.10 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a123b a123x} +} {a123b a123x} +test cmdIL-4.11 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b aab} +} {a1b aab} +test cmdIL-4.12 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b a!b} +} {a!b a1b} +test cmdIL-4.13 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b2c a1b1c} +} {a1b1c a1b2c} +test cmdIL-4.14 {DictionaryCompare procedure, numerics} { + lsort -dictionary {a1b2c a1b3c} +} {a1b2c a1b3c} +test cmdIL-4.15 {DictionaryCompare procedure, long numbers} { + lsort -dictionary {a7654884321988762b a7654884321988761b} +} {a7654884321988761b a7654884321988762b} +test cmdIL-4.16 {DictionaryCompare procedure, long numbers} { + lsort -dictionary {a8765488432198876b a7654884321988761b} +} {a7654884321988761b a8765488432198876b} +test cmdIL-4.17 {DictionaryCompare procedure, case} { + lsort -dictionary {aBCd abcc} +} {abcc aBCd} +test cmdIL-4.18 {DictionaryCompare procedure, case} { + lsort -dictionary {aBCd abce} +} {aBCd abce} +test cmdIL-4.19 {DictionaryCompare procedure, case} { + lsort -dictionary {abcd ABcc} +} {ABcc abcd} +test cmdIL-4.20 {DictionaryCompare procedure, case} { + lsort -dictionary {abcd ABce} +} {abcd ABce} +test cmdIL-4.21 {DictionaryCompare procedure, case} { + lsort -dictionary {abCD ABcd} +} {ABcd abCD} +test cmdIL-4.22 {DictionaryCompare procedure, case} { + lsort -dictionary {ABcd aBCd} +} {ABcd aBCd} +test cmdIL-4.23 {DictionaryCompare procedure, case} { + lsort -dictionary {ABcd AbCd} +} {ABcd AbCd} +test cmdIL-4.24 {DictionaryCompare procedure, international characters} utf8 { + set result [lsort -dictionary "a b c A B C \xe3 \xc4"] + set result +} "A a B b C c \xe3 \xc4" +test cmdIL-4.25 {DictionaryCompare procedure, international characters} utf8 { + set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"] + set result +} "a23\xe3 a23\xe4 a23\xc5" +test cmdIL-4.26 {DefaultCompare procedure, signed characters} { + set l [lsort [list "abc\200" "abc"]] + set viewlist {} + foreach s $l { + set viewelem "" + set len [string length $s] + for {set i 0} {$i < $len} {incr i} { + set c [string index $s $i] + scan $c %c d + if {$d > 0 && $d < 128} { + append viewelem $c + } else { + append viewelem "\\[format %03o $d]" + } + } + lappend viewlist $viewelem + } + set viewlist +} [list "abc" "abc\\200"] +test cmdIL-4.27 {DictionaryCompare procedure, signed characters} { + set l [lsort -dictionary [list "abc\200" "abc"]] + set viewlist {} + foreach s $l { + set viewelem "" + set len [string length $s] + for {set i 0} {$i < $len} {incr i} { + set c [string index $s $i] + scan $c %c d + if {$d > 0 && $d < 128} { + append viewelem $c + } else { + append viewelem "\\[format %03o $d]" + } + } + lappend viewlist $viewelem + } + set viewlist +} [list "abc" "abc\\200"] testreport diff --git a/tests/package.test b/tests/package.test index b8afa18..1484bd6 100644 --- a/tests/package.test +++ b/tests/package.test @@ -20,5 +20,17 @@ test package-1.3 {package names} -body { expr {"stdlib" in [package names]} } -result 1 +test package-2.1 {package forget} -body { + # First pretend the package was loaded + package provide forget-test + # Now it won't load anything + package require forget-test + # Now forget it and another unloaded test + package forget forget-test missing + # And load the local package + package require forget-test + info exists forgotten +} -result 1 + testreport diff --git a/tests/try.test b/tests/try.test index 0d76865..36a9bf9 100644 --- a/tests/try.test +++ b/tests/try.test @@ -104,7 +104,7 @@ test try-2.1 "try ... trap" -body { try { a } trap CUSTOM {msg opts} { - list $msg $opts(-code) $opts(-errorcode) + list $msg [dict get $opts -code] [dict get $opts -errorcode] } } -result {{custom errorcode} 1 {CUSTOM RESULT}} @@ -140,6 +140,13 @@ test try-2.5 "trap match first but not second" -body { } } -returnCodes error -result failed +test try-2.6 "trap match too long" -body { + try { + apply {{} {return -code error -errorcode {FOO BAR} failed}} + } trap {FOO BAR BAZ} {msg opts} { + list trapped + } +} -returnCodes error -result failed proc c {} { try { |