aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorSteve Bennett <steveb@workware.net.au>2020-04-18 09:34:25 +1000
committerSteve Bennett <steveb@workware.net.au>2020-05-04 21:57:34 +1000
commitda82368c816c8d06f425aa3f25a2a918fdba1df1 (patch)
treee1dc05358910d168edc982ed05523d0b30ad24d5 /tests
parent8a5861eb51c32e41d638181188c256c1dbb93c96 (diff)
downloadjimtcl-da82368c816c8d06f425aa3f25a2a918fdba1df1.zip
jimtcl-da82368c816c8d06f425aa3f25a2a918fdba1df1.tar.gz
jimtcl-da82368c816c8d06f425aa3f25a2a918fdba1df1.tar.bz2
tests: Add many new additional tests for code coverage
readdir, tty, utf8, signal, alarm, kill, file, jimsh, posix, aio, history, interp, pack, unpack, eventloop, exec, load, package, regexp, regsub Signed-off-by: Steve Bennett <steveb@workware.net.au>
Diffstat (limited to 'tests')
-rw-r--r--tests/aio.test121
-rw-r--r--tests/coverage.test245
-rw-r--r--tests/dict2.test32
-rw-r--r--tests/event.test28
-rw-r--r--tests/exec2.test70
-rw-r--r--tests/exists.test40
-rw-r--r--tests/expr-new.test49
-rw-r--r--tests/file.test263
-rw-r--r--tests/history.test43
-rw-r--r--tests/jim.test65
-rw-r--r--tests/jiminterp.test27
-rw-r--r--tests/jimsh.test40
-rw-r--r--tests/load.test109
-rw-r--r--tests/loadtest.c36
-rw-r--r--tests/pack.test118
-rw-r--r--tests/package.test16
-rw-r--r--tests/posix.test37
-rw-r--r--tests/proc.test4
-rw-r--r--tests/regcount.test12
-rw-r--r--tests/regexp.test82
-rw-r--r--tests/regexp2.test27
-rw-r--r--tests/signal.test109
-rw-r--r--tests/tty.test48
-rw-r--r--tests/utf8.test20
24 files changed, 1589 insertions, 52 deletions
diff --git a/tests/aio.test b/tests/aio.test
new file mode 100644
index 0000000..d3f5931
--- /dev/null
+++ b/tests/aio.test
@@ -0,0 +1,121 @@
+source [file dirname [info script]]/testing.tcl
+
+needs constraint jim
+
+makeFile {test-data} testdata.in
+set f [open testdata.in]
+
+defer {
+ $f close
+}
+
+test aio-1.1 {seek usage} -body {
+ $f seek
+} -returnCodes error -match glob -result {wrong # args: should be "* seek offset ?start|current|end"}
+
+test aio-1.2 {seek start} -body {
+ $f seek 2
+ $f tell
+} -result {2}
+
+test aio-1.3 {seek start} -body {
+ $f seek 4 start
+ $f tell
+} -result {4}
+
+test aio-1.4 {read after seek} -body {
+ set c [$f read 1]
+ list $c [$f tell]
+} -result {- 5}
+
+test aio-1.5 {seek backwards} -body {
+ $f seek -2 current
+ set c [$f read 1]
+ list $c [$f tell]
+} -result {t 4}
+
+test aio-1.6 {seek from end} -body {
+ $f seek -2 end
+ set c [$f read 2]
+ list $c [$f tell]
+} -result [list "a\n" 10]
+
+test aio-1.7 {seek usage} -body {
+ $f seek 4 bad
+} -returnCodes error -match glob -result {wrong # args: should be "* seek offset ?start|current|end"}
+
+test aio-1.8 {seek usage} -body {
+ $f seek badint
+} -returnCodes error -match glob -result {expected integer but got "badint"}
+
+test aio-1.9 {seek bad pos} -body {
+ $f seek -20
+} -returnCodes error -match glob -result {testdata.in: Invalid argument}
+
+test aio-2.1 {read usage} -body {
+ $f read -nonoption
+} -returnCodes error -result {expected integer but got "-nonoption"}
+
+test aio-2.2 {read usage} -body {
+ $f read badint
+} -returnCodes error -result {expected integer but got "badint"}
+
+test aio-2.3 {read -ve len} -body {
+ $f read " -20"
+} -returnCodes error -result {invalid parameter: negative len}
+
+test aio-2.4 {read too many args} -body {
+ $f read 20 extra
+} -returnCodes error -match glob -result {wrong # args: should be "* read ?-nonewline? ?len?"}
+
+test aio-3.1 {copy to invalid fh} -body {
+ $f copy lambda
+} -returnCodes error -result {Not a filehandle: "lambda"}
+
+test aio-3.2 {copy bad length} -body {
+ $f copy stdout invalid
+} -returnCodes error -result {expected integer but got "invalid"}
+
+set badvar a
+
+test aio-4.1 {gets invalid var} -body {
+ $f gets badvar(abc)
+} -returnCodes error -result {can't set "badvar(abc)": variable isn't array}
+
+test aio-5.1 {puts usage} -body {
+ stdout puts -badopt abc
+} -returnCodes error -result {wrong # args: should be "stdout puts ?-nonewline? str"}
+
+test aio-6.1 {eof} {
+ $f seek 0
+ $f eof
+} {0}
+
+test aio-6.2 {eof} {
+ # eof won't trigger until we try to read
+ $f seek 0 end
+ $f eof
+} {0}
+
+test aio-6.3 {eof} {
+ $f read 1
+ $f eof
+} {1}
+
+test aio-7.1 {close args} -body {
+ $f close badopt
+} -returnCodes error -result {bad option "badopt": must be -nodelete, r, or w}
+
+test aio-7.2 {close w on non-socket} -body {
+ $f close w
+} -returnCodes error -result {Socket operation on non-socket}
+
+test aio-7.3 {close -nodelete on non-socket} -body {
+ $f close -nodelete
+} -returnCodes error -result {not supported}
+
+test aio-8.1 {filename} {
+ $f filename
+} testdata.in
+
+testreport
diff --git a/tests/coverage.test b/tests/coverage.test
new file mode 100644
index 0000000..b99b273
--- /dev/null
+++ b/tests/coverage.test
@@ -0,0 +1,245 @@
+# various tests to improve code coverage
+
+source [file dirname [info script]]/testing.tcl
+
+testCmdConstraints ref rand
+
+testConstraint debug-invstr 0
+catch {
+ debug -commands
+ testConstraint debug-invstr 1
+}
+
+test dupobj-1 {duplicate script object} {
+ set y {expr 2}
+ # make y a script
+ eval $y
+ # Now treat it as a list that needs duplicating
+ lset y 0 abc
+ set y
+} {abc 2}
+
+test dupobj-2 {duplicate expr object} {
+ set y {2 + 1}
+ # make y an expression
+ expr $y
+ # Now treat it as a list that needs duplicating
+ lset y 0 abc
+ set y
+} {abc + 1}
+
+test dupobj-3 {duplicate interpolated object} {
+ set w 4
+ set y def($w)
+ # Now treat it as a namespace object that needs duplicating
+ namespace eval $y {}
+ apply [list x {set x 1} $y] x
+} {1}
+
+test dupobj-4 {duplicate dict subst object} {
+ # make y a dict subst
+ set def(4) 5
+ set y def(4)
+ incr $y
+ # Now treat it as a namespace object that needs duplicating
+ namespace eval $y {}
+ apply [list x {set x 1} $y] x
+} {1}
+
+test dupobj-5 {duplicate object with no string rep} {
+ # A sorted list has no string rep
+ set y [lsort {abc def}]
+ # Now treat it as a namespace object that needs duplicating
+ namespace eval $y {}
+ apply [list x {set x 1} $y] x
+} {1}
+
+test dupobj-6 {duplicate object with no type dup proc} {
+ set x 6
+ incr x
+ # x is now an int, an object with no dup proc
+ # using as a namespace requires the object to be duplicated
+ namespace eval $x {
+ proc a {} {}
+ rename a ""
+ }
+} {}
+
+test dupobj-7 {duplicate scan obj} {
+ set x "%d %d"
+ scan "1 4" $x y z
+ # Now treat it as a namespace object that needs duplicating
+ namespace eval $x {}
+ apply [list x {set x 1} $x] x
+} {1}
+
+
+test script-1 {convert empty object to script} {
+ set empty [foreach a {} {}]
+ eval $empty
+} {}
+
+test ref-1 {treat something as a reference} ref {
+ set ref [ref abc tag]
+ append ref " "
+ getref " $ref "
+} {abc}
+
+test ref-2 {getref invalid reference} -constraints ref -body {
+ getref "<reference.<tag____>.99999999999999000000>"
+} -returnCodes error -match glob -result {invalid reference id *}
+
+test ref-3 {getref invalid reference tag} -constraints ref -body {
+ getref "<reference.<tag!%(*>.99999999999999000000>"
+} -returnCodes error -match glob -result {expected reference but got "<reference.<tag!%(*>.99999999999999000000>"}
+
+test ref-4 {finalize} ref {
+ finalize $ref
+} {}
+
+test ref-5 {finalize} ref {
+ finalize $ref cleanup
+ finalize $ref cleanup2
+ finalize $ref
+} {cleanup2}
+
+test ref-6 {finalize get invalid reference} -constraints ref -body {
+ finalize "<reference.<tag____>.99999999999999000000>"
+} -returnCodes error -match glob -result {invalid reference id *}
+
+test ref-7 {finalize set invalid reference} -constraints ref -body {
+ finalize "<reference.<tag____>.99999999999999000000>" cleanup
+} -returnCodes error -match glob -result {invalid reference id *}
+
+test collect-1 {recursive collect} ref {
+ set ref2 [ref dummy cleanup2]
+ unset ref2
+ proc cleanup2 {ref value} {
+ # Try to call collect
+ stdout puts "in cleanup2: ref=$ref, value=$value"
+ if {[collect]} {
+ error "Should return 0"
+ }
+ }
+ collect
+} {1}
+
+test scan-1 {update string of scan obj} debug-invstr {
+ set x "%d %d"
+ scan "1 4" $x y z
+ debug invstr $x
+ # x is now of scanfmt type with no string rep
+ set x
+} {%d %d}
+
+# It is too hard to do this one without debug invstr
+test index-1 {update string of index} debug-invstr {
+ set x end-1
+ lindex {a b c} $x
+ debug invstr $x
+ # x is now of index type with no string rep
+ set x
+} {end-1}
+
+test index-2 {update string of index} debug-invstr {
+ set x end
+ lindex {a b c} $x
+ debug invstr $x
+ # x is now of index type with no string rep
+ set x
+} {end}
+
+test index-3 {update string of index} debug-invstr {
+ set x 2
+ lindex {a b c} $x
+ debug invstr $x
+ # x is now of index type with no string rep
+ set x
+} {2}
+
+test index-4 {index > INT_MAX} debug-invstr {
+ set x 99999999999
+ incr x
+ # x is now of int type > INT_MAX
+ lindex {a b c} $x
+} {}
+
+test cmd-1 {standard -commands} jim {
+ expr {"length" in [string -commands]}
+} {1}
+
+test rand-1 {rand} -constraints rand -body {
+ rand 1 2 3
+} -returnCodes error -result {wrong # args: should be "rand ?min? max"}
+
+test rand-2 {rand} -constraints rand -body {
+ rand foo
+} -returnCodes error -result {expected integer but got "foo"}
+
+test rand-3 {rand} -constraints rand -body {
+ rand 2 bar
+} -returnCodes error -result {expected integer but got "bar"}
+
+test rand-4 {rand} rand {
+ string is integer [rand]
+} {1}
+
+test rand-5 {srand} rand {
+ set x [expr {srand(123)}]
+ if {$x >= 0 && $x <= 1} {
+ return 1
+ } else {
+ return 0
+ }
+} {1}
+
+test lreverse-1 {lreverse} -body {
+ lreverse
+} -returnCodes error -result {wrong # args: should be "lreverse list"}
+
+test divide-1 {expr} -constraints jim -body {
+ / 2 0
+} -returnCodes error -result {Division by zero}
+
+test package-1 {package names} jim {
+ expr {"stdlib" in [package names]}
+} {1}
+
+test variable-1 {upvar to invalid name} -constraints jim -body {
+ proc a {} {
+ upvar var\0null abc
+ incr abc
+ }
+ a
+} -returnCodes error -result {variable name contains embedded null}
+
+test variable-2 {upvar to global name} {
+ set ::globalvar 1
+ proc a {} {
+ upvar ::globalvar abc
+ incr abc
+ }
+ a
+} {2}
+
+test unknown-1 {recursive unknown} -body {
+ # unknown will call itself a maximum of 50 times before simply returning an error
+ proc unknown {args} {
+ nonexistent 3
+ }
+ nonexistent 4
+} -returnCodes error -result {invalid command name "nonexistent"} -cleanup {
+ rename unknown {}
+}
+
+test interpolate-1 {interpolate} -body {
+ unset -nocomplain a
+ for {set i 0} {$i < 10} {incr i} {
+ set a($i) $i
+ }
+ set x "$a(0)$a(1)$a(2)$a(3)$a(4)$a(5)$a(6)$a(7)$a(8)$a(9)$nonexistent"
+ set x
+} -returnCodes error -result {can't read "nonexistent": no such variable}
+
+
+testreport
diff --git a/tests/dict2.test b/tests/dict2.test
index 54d4d0d..f4d147a 100644
--- a/tests/dict2.test
+++ b/tests/dict2.test
@@ -95,7 +95,7 @@ test dict-3.10 {dict get command} -returnCodes error -body {
test dict-3.11 {dict get command} {dict get [dict create a b c d] a} b
test dict-3.12 {dict get command} -returnCodes error -body {
dict get
-} -result {wrong # args: should be "dict get dictionary ?key ...?"}
+} -match glob -result {wrong # args: should be "dict get dictionary ?key*?"}
test dict-3.13 {dict get command} -body {
set dict [dict get {a b c d}]
if {$dict eq "a b c d"} {
@@ -1250,5 +1250,35 @@ test dict-22.11 {dict with command: no recursive structures [Bug 1786481]} -body
} -cleanup {
unset foo t inner
} -result OK
+
+set dictnulls {ab\0c de\0f \0ghi kl\0m}
+set dictgood [array get tcl_platform]
+set dictbad {abc def ghi}
+
+test dict-23.1 {dict info} {
+ regexp {entries in table,.*buckets} [dict info $dictgood]
+} {1}
+
+test dict-23.2 {dict info usage} -body {
+ dict info
+} -returnCodes error -result {wrong # args: should be "dict info dictionary"}
+
+test dict-23.3 {dict info baddict} -body {
+ dict info $dictbad
+} -returnCodes error -result {missing value to go with key}
+
+test dict-23.4 {dict with usage} -body {
+ dict with
+} -returnCodes error -result {wrong # args: should be "dict with dictVar ?key ...? script"}
+
+test dict-23.5 {dict with badvar} -constraints jim -body {
+ # set up a variable that will fail Jim_SetVariable()
+ dict with dictnulls {}
+} -returnCodes error -result {variable name contains embedded null}
+
+test dict-23.6 {dict with baddict} -body {
+ dict with dictbad {}
+} -returnCodes error -result {missing value to go with key}
+
testreport
diff --git a/tests/event.test b/tests/event.test
index 123b17c..3228684 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -81,6 +81,19 @@ test event-7.3 {bgerror / accumulation / break} {
set errRes;
} err1
+# Tcl handles errors in bgerror slightly differently
+# Jim prints the original error to stderr
+test event-7.4 {bgerror throws an error} -constraints jim -body {
+ exec [info nameofexecutable] - << {
+ proc bgerror {err} {
+ error "inside bgerror"
+ }
+ after 0 {error err1}
+ update
+ }
+} -result {stdin:3: Error: inside bgerror
+at file "stdin", line 3}
+
# end of bgerror tests
catch {rename bgerror {}}
@@ -212,6 +225,21 @@ test event-13.1 "vwait/signal" signal {
} msg] $msg
} {5 SIGALRM}
+test event-13.2 {after info invalid} -body {
+ after info not-a-valid-id
+} -returnCodes error -result {event "not-a-valid-id" doesn't exist}
+
+test event-13.3 {after info noexist} -body {
+ after info after#99999999
+} -returnCodes error -result {event "after#99999999" doesn't exist}
+
+test event-13.4 {after info usage} -body {
+ after info too-many args
+} -returnCodes error -result {wrong # args: should be "after info ?id?"}
+
+test event-13.5 {after cancel noexist} {
+ after cancel after#99999999
+} {}
test event-14.1 {socket stream.server client address} {jim socket} {
set s1 [socket stream.server 5001]
diff --git a/tests/exec2.test b/tests/exec2.test
index b4b42cc..253d251 100644
--- a/tests/exec2.test
+++ b/tests/exec2.test
@@ -5,9 +5,8 @@
source [file dirname [info script]]/testing.tcl
needs cmd exec
-foreach i {pipe signal wait} {
- testConstraint $i [expr {[info commands $i] ne ""}]
-}
+testCmdConstraints pipe signal wait alarm
+
# Some Windows platforms (e.g. AppVeyor) produce ENOSPC rather than killing
# the child with SIGPIPE). So turn off this test for that platform
if {[info exists env(MSYSTEM)] && $env(MSYSTEM) eq "MINGW32"} {
@@ -100,4 +99,69 @@ test exec2-3.4 "wait for background task" -constraints wait -body {
}
} -result {CHILDSTATUS 0}
+test exec2-4.1 {redirect from invalid filehandle} -body {
+ exec cat <@bogus
+} -returnCodes error -result {invalid command name "bogus"}
+
+test exec2-4.2 {env is invalid dict} -constraints jim -body {
+ set saveenv $env
+ lappend env bogus
+ catch {exec pwd}
+} -result {0} -cleanup {
+ set env $saveenv
+}
+
+test exec2-4.3 {signalled process during foreground exec} -constraints {jim alarm} -body {
+ # We need to exec a pipeline and then have one process
+ # be killed by a signal
+ exec [info nameofexecutable] -e {alarm 0.1; sleep 0.5}
+} -returnCodes error -result {child killed by signal SIGALRM}
+
+test exec2-4.4 {exec - consecutive |} -body {
+ exec echo | | test
+} -returnCodes error -result {illegal use of | or |& in command}
+
+test exec2-4.5 {exec - consecutive | with &} -body {
+ exec echo | | test &
+} -returnCodes error -result {illegal use of | or |& in command}
+
+test exec2-4.6 {exec - illegal channel} -body {
+ exec echo hello >@nonexistent
+} -returnCodes error -result {invalid command name "nonexistent"}
+
+test exec2-5.1 {wait with invalid pid} wait {
+ wait 9999999
+} {NONE -1 -1}
+
+test exec2-5.2 {wait with invalid pid} -constraints wait -body {
+ wait blah
+} -returnCodes error -result {expected integer but got "blah"}
+
+test exec2-5.3 {wait - bad args} -constraints wait -body {
+ wait too many args
+} -returnCodes error -result {wrong # args: should be "wait ?-nohang? ?pid?"}
+
+test exec2-5.4 {wait -nohang} -constraints wait -body {
+ set pid [exec sleep 0.2 &]
+ # first wait will do nothing as the process is not finished
+ wait -nohang $pid
+ wait $pid
+} -match glob -result {CHILDSTATUS * 0}
+
+test exec2-5.5 {wait for all children} -body {
+ # We want to have children finish at different times
+ # so that we test the handling of the wait table
+ foreach i {0.1 0.2 0.6 0.5 0.4 0.3} {
+ exec sleep $i &
+ }
+ # reap zombies, there should not be any
+ wait
+ sleep 0.3
+ # reap zombies, 2-3 should be finished now
+ wait
+ sleep 0.4
+ # reap zombies, all processes should be finished now
+ wait
+} -result {}
+
testreport
diff --git a/tests/exists.test b/tests/exists.test
index 11e8781..79f9da0 100644
--- a/tests/exists.test
+++ b/tests/exists.test
@@ -1,79 +1,87 @@
source [file dirname [info script]]/testing.tcl
needs cmd exists
-testConstraint lambda [expr {[info commands lambda] ne {}}]
+testCmdConstraints lambda
test exists-1.1 "Exists var" {
set a 1
exists a
} 1
-test exists-1.1 "Exists var" {
+test exists-1.2 "Exists var" {
unset -nocomplain b
exists b
} 0
-test exists-1.1 "Exists -var" {
+test exists-1.3 "Exists -var" {
exists -var a
} 1
-test exists-1.1 "Exists -var" {
+test exists-1.4 "Exists -var" {
exists -var b
} 0
-test exists-1.1 "Exists in proc" {
+test exists-1.5 "Exists in proc" {
proc a {name} { exists $name }
a ::a
} 1
-test exists-1.1 "Exists in proc" {
+test exists-1.6 "Exists in proc" {
a ::b
} 0
-test exists-1.1 "Exists in proc" {
+test exists-1.7 "Exists in proc" {
a name
} 1
-test exists-1.1 "Exists in proc" {
+test exists-1.8 "Exists in proc" {
a none
} 0
-test exists-1.1 "Exists -proc" {
+test exists-1.9 "Exists -proc" {
exists -proc a
} 1
-test exists-1.1 "Exists -proc" {
+test exists-1.10 "Exists -proc" {
exists -proc bogus
} 0
-test exists-1.1 "Exists -proc" {
+test exists-1.11 "Exists -proc" {
exists -proc info
} 0
-test exists-1.1 "Exists -command" {
+test exists-1.12 "Exists -command" {
exists -command a
} 1
-test exists-1.1 "Exists -command" {
+test exists-1.13 "Exists -command" {
exists -command info
} 1
-test exists-1.1 "Exists -command" {
+test exists-1.14 "Exists -command" {
exists -command bogus
} 0
-test exists-1.1 "Exists local lambda after exit" lambda {
+test exists-1.15 "Exists local lambda after exit" lambda {
proc a {} {
local lambda {} {dummy}
}
exists -proc [a]
} 0
-test exists-1.1 "Exists local lambda" lambda {
+test exists-1.16 "Exists local lambda" lambda {
proc a {} {
exists -proc [local lambda {} {dummy}]
}
a
} 1
+test exists-1.17 {exists usage} -body {
+ exists -dummy blah
+} -returnCodes error -result {bad option "-dummy": must be -alias, -command, -proc, or -var}
+
+test exists-1.18 {exists usage} -body {
+ exists abc def ghi
+} -returnCodes error -result {wrong # args: should be "exists ?option? name"}
+
testreport
diff --git a/tests/expr-new.test b/tests/expr-new.test
index f81c911..851d55d 100644
--- a/tests/expr-new.test
+++ b/tests/expr-new.test
@@ -640,6 +640,55 @@ test expr-21.1 {expr shimmering} {
expr $x
} {4}
+test expr-22.1 {expr} -body {
+ expr {1 + $nonexistent}
+} -returnCodes error -result {can't read "nonexistent": no such variable}
+
+test expr-22.2 {expr} -body {
+ expr {~$nonexistent}
+} -returnCodes error -result {can't read "nonexistent": no such variable}
+
+test expr-22.3 {expr} -body {
+ expr {abs($nonexistent)}
+} -returnCodes error -result {can't read "nonexistent": no such variable}
+
+test expr-22.4 {expr} -body {
+ expr {[nonexistent] << 4}
+} -returnCodes error -result {invalid command name "nonexistent"}
+
+test expr-22.5 {expr} -body {
+ expr {5 >> [nonexistent]}
+} -returnCodes error -result {invalid command name "nonexistent"}
+
+test expr-22.6 {expr} -body {
+ expr {$nonexistent in {a b c}}
+} -returnCodes error -result {can't read "nonexistent": no such variable}
+
+test expr-22.7 {expr} -body {
+ expr {"a" ni $nonexistent}
+} -returnCodes error -result {can't read "nonexistent": no such variable}
+
+test expr-22.8 {expr} -body {
+ expr {5 + $}
+} -returnCodes error -result {syntax error in expression: "5 + $"}
+
+test expr-22.9 {expr} -body {
+ expr {. + 1}
+} -returnCodes error -result {syntax error in expression: ". + 1"}
+
+test expr-22.10 {expr} -body {
+ expr {5 + ,}
+} -returnCodes error -result {unexpected comma in expression: "5 + ,"}
+
+test expr-22.11 {expr} -body {
+ expr {round(1,2,3,4)}
+} -returnCodes error -result {too many arguments to math function}
+
+test expr-22.12 {expr} {
+ expr {inf}
+} {Inf}
+
+
# cleanup
if {[info exists a]} {
unset a
diff --git a/tests/file.test b/tests/file.test
index fb5a555..049469d 100644
--- a/tests/file.test
+++ b/tests/file.test
@@ -1,6 +1,10 @@
source [file dirname [info script]]/testing.tcl
needs cmd file
+catch {file link} msg
+testConstraint filelink [string match "wrong # args:*" $msg]
+catch {file lstat} msg
+testConstraint filelstat [string match "wrong # args:*" $msg]
test join-1.1 "One name" {
file join abc
@@ -117,6 +121,265 @@ test dirname-1.4 "Trailing slash" {
file dirname abc/
} {.}
+test dirname-1.5 ".." {
+ # Should be . to match Tcl
+ file dirname ..
+} {..}
+
+test dirname-1.6 "abc/.." {
+ file dirname abc/..
+} {abc}
+
+test dirname-1.7 "../abc" {
+ file dirname ../abc
+} {..}
+
+test stat-1.1 {file stat usage} -body {
+ file stat
+} -returnCodes error -match glob -result {wrong # args: should be "file stat name*"}
+
+test stat-1.2 {file stat usage} -body {
+ file stat nonexistent a
+} -returnCodes error -match glob -result {could not read "nonexistent": *}
+
+test stat-1.3 {file stat} {
+ unset -nocomplain a
+ file stat [info script] a
+ set a(type)
+} {file}
+
+test stat-1.4 {file stat update array} {
+ set a(type) bogus
+ file stat [info nameofexecutable] a
+ set a(type)
+} {file}
+
+test stat-1.5 {file stat update bad array} -body {
+ unset -nocomplain a
+ # invalid dict/array
+ set a {1 2 3}
+ file stat [info nameofexecutable] a
+} -returnCodes error -result {can't set "a(dev)": variable isn't array}
+
+test stat-1.7 {file stat no variable} jim {
+ set a [file stat [info script]]
+ set a(type)
+} {file}
+
+test ext-1.1 {file ext} -body {
+ file ext
+} -returnCodes error -result {wrong # args: should be "file extension name"}
+
+test ext-1.2 {file ext basic} {
+ file ext abc.def
+} {.def}
+
+test ext-1.3 {file ext path} {
+ file ext 123/abc.def
+} {.def}
+
+test ext-1.4 {file ext noext} {
+ file ext abc
+} {}
+
+test ext-1.5 {file ext noext} {
+ file ext abc.def/ghi
+} {}
+
+test rootname-1.1 {file rootname} -body {
+ file rootname
+} -returnCodes error -result {wrong # args: should be "file rootname name"}
+
+test rootname-1.2 {file rootname basic} -body {
+ file rootname abc
+} -result {abc}
+
+test rootname-1.3 {file rootname basic} -body {
+ file rootname abc/def
+} -result {abc/def}
+
+test rootname-1.4 {file rootname basic} -body {
+ file rootname abc.c
+} -result {abc}
+
+test rootname-1.5 {file rootname basic} -body {
+ file rootname abc/def.c
+} -result {abc/def}
+
+test rootname-1.6 {file rootname odd cases} -body {
+ file rootname abc/def.c/ghi
+} -result {abc/def.c/ghi}
+
+test readable-1.1 {file readable} {
+ file readable [info script]
+} {1}
+
+test writable-1.1 {file writable} -body {
+ set name tmp.[pid]
+ makeFile testing $name
+ file writable $name
+} -result 1 -cleanup {
+ file delete $name
+}
+
+test rename-1.1 {file rename usage} -body {
+ file rename
+} -returnCodes error -match glob -result {wrong # args: should be *}
+
+test rename-1.2 {file rename usage} -body {
+ file rename -badarg name1 name2
+} -returnCodes error -match glob -result {*}
+
+test rename-1.1 {file rename, target exists} -body {
+ set name1 tmp.[pid]
+ set name2 tmp2.[pid]
+ makeFile testing $name1
+ makeFile testing2 $name2
+ file rename $name1 $name2
+} -returnCodes error -match glob -result {error renaming *}
+
+test rename-1.2 {file rename -force, target exists} -body {
+ file rename -force $name1 $name2
+ list [file exists $name1] [file exists $name2]
+} -result {0 1} -cleanup {
+ file delete $name2
+}
+
+test link-1.1 {file link usage} -constraints filelink -body {
+ file link
+} -returnCodes error -match glob -result {wrong # args: should be "file link*}
+
+test link-1.2 {file hard link} -constraints filelink -body {
+ set name tmp.[pid]
+ file link $name [info script]
+ file exists $name
+} -result {1} -cleanup {
+ file delete $name
+}
+
+test link-1.3 {file hard link} -constraints filelink -body {
+ set name tmp.[pid]
+ file link -hard $name [info script]
+ file exists $name
+} -result {1} -cleanup {
+ file delete $name
+}
+
+test link-1.4 {file sym link} -constraints filelink -body {
+ set name tmp.[pid]
+ file link -sym $name [info script]
+ list [file exists $name] [file tail [file readlink $name]]
+} -result {1 file.test} -cleanup {
+ file delete $name
+}
+
+test link-1.5 {file readlink, bad link} -constraints filelink -body {
+ file readlink [info script]
+} -returnCodes error -match glob -result {could*read*link "*file.test": *}
+
+test link-1.6 {file link badopt} -constraints filelink -body {
+ file link -bad name1 name2
+} -returnCodes error -match glob -result {bad * "-bad": must be *}
+
+test lstat-1.1 {file lstat} -constraints filelstat -body {
+ file lstat
+} -returnCodes error -match glob -result {wrong # args: should be "file lstat name *}
+
+test lstat-1.2 {file lstat} -constraints filelstat -body {
+ file lstat nonexistent ls
+} -returnCodes error -match glob -result {could not read "nonexistent": *}
+
+test lstat-1.3 {file lstat} -constraints {filelink filelstat} -body {
+ set name tmp.[pid]
+ file link -sym $name [info script]
+ unset -nocomplain s ls
+ file lstat $name ls
+ file stat [info script] s
+ list $ls(type) $s(type)
+} -match glob -result {link file} -cleanup {
+ file delete $name
+}
+
+test type-1.1 {file type} {
+ file type [info script]
+} {file}
+
+test type-1.2 {file type} {
+ file type [file dirname [info script]]
+} {directory}
+
+test type-1.2 {file type} -body {
+ file type nonexistent
+} -returnCodes error -match glob -result {could not read "nonexistent": *}
+
+test isfile-1.1 {file isfile} -body {
+ file isfile
+} -returnCodes error -result {wrong # args: should be "file isfile name"}
+
+test isfile-1.2 {file isfile} {
+ file isfile [info script]
+} {1}
+
+test isfile-1.3 {file isfile} {
+ file isfile [file dirname [info script]]
+} {0}
+
+test size-1.1 {file size} -body {
+ file size
+} -returnCodes error -result {wrong # args: should be "file size name"}
+
+test size-1.2 {file size} -body {
+ file size nonexistent
+} -returnCodes error -match glob -result {could not read "nonexistent":*}
+
+test size-1.3 {file size} {
+ set size [file size [info script]]
+ file stat [info script] s
+ expr {$size - $s(size)}
+} {0}
+
+test mtime-1.1 {file mtime} -body {
+ file mtime
+} -returnCodes error -result {wrong # args: should be "file mtime name ?time?"}
+
+test mtime-1.2 {file mtime} -body {
+ file mtime nonexistent
+} -returnCodes error -match glob -result {could not read "nonexistent":*}
+
+test mtime-1.3 {file mtime} -body {
+ file mtime [info script] bad
+} -returnCodes error -result {expected integer but got "bad"}
+
+test mtime-1.4 {file mtime} {
+ set mtime [file mtime [info script]]
+ file stat [info script] s
+ expr {$mtime - $s(mtime)}
+} {0}
+
+test mtime-1.5 {file mtime} -body {
+ set name tmp.[pid]
+ makeFile testing $name
+ set t [file mtime [info script]]
+ file mtime $name $t
+ expr {$t - [file mtime $name]}
+} -result {0} -cleanup {
+ file delete $name
+}
+
+test atime-1.1 {file atime} -body {
+ file atime
+} -returnCodes error -match glob -result {wrong # args: should be "file atime name*}
+
+test atime-1.2 {file atime} -body {
+ file atime nonexistent
+} -returnCodes error -match glob -result {could not read "nonexistent":*}
+
+test atime-1.3 {file atime} {
+ set atime [file atime [info script]]
+ file stat [info script] s
+ expr {$atime - $s(atime)}
+} {0}
+
# These tests are courtesy of picol
test file.12.1 "picol test" {file dirname /foo/bar/grill.txt} /foo/bar
diff --git a/tests/history.test b/tests/history.test
new file mode 100644
index 0000000..178a107
--- /dev/null
+++ b/tests/history.test
@@ -0,0 +1,43 @@
+source [file dirname [info script]]/testing.tcl
+
+needs cmd history
+
+test history-1.1 {history usage} -body {
+ history
+} -returnCodes error -result {wrong # args: should be "history command ..."
+Use "history -help ?command?" for help}
+
+test history-1.2 {history -help} -body {
+ history -help
+} -result {Usage: "history command ... ", where command is one of: getline, completion, load, save, add, show}
+
+test history-1.2 {history add} {
+ history add line1
+ history add "line2 next"
+ set name tmp.[pid]
+ history save $name
+ set f [open $name]
+ set lines [split [string trimright [read $f]] \n]
+} {line1 {line2 next}}
+
+test history-1.3 {history load} {
+ history load $name
+} {}
+
+test history-1.4 {history completion usage} -body {
+ history completion
+} -returnCodes error -result {wrong # args: should be "history completion command"}
+
+test history-1.5 {history completion} {
+ history completion command
+} {}
+
+test history-1.6 {history completion} {
+ history completion {}
+} {}
+
+file delete $name
+
+# Can't really tests history add, show, setcompletion
+
+testreport
diff --git a/tests/jim.test b/tests/jim.test
index 3a0e357..121e909 100644
--- a/tests/jim.test
+++ b/tests/jim.test
@@ -11,8 +11,7 @@ source [file dirname [info script]]/testing.tcl
needs constraint jim
catch {package require regexp}
-testConstraint regexp [expr {[info commands regexp] ne {}}]
-testConstraint lambda [expr {[info commands ref] ne {}}]
+testCmdConstraints regexp readdir lambda
################################################################################
# SET
@@ -3340,7 +3339,7 @@ test range-1.9 {basic range test} {
test range-2.0 {foreach range test} {
set k 0
foreach {x y} [range 100] {
- incr k [expr {$x*$y}]
+ incr k [expr {$x*$y}]
}
set k
} {164150}
@@ -3349,8 +3348,8 @@ test range-2.1 {foreach range test without obj reuse} {
set k 0
set trash {}
foreach {x y} [range 100] {
- incr k [expr {$x*$y}]
- lappend trash $x $y
+ incr k [expr {$x*$y}]
+ lappend trash $x $y
}
set trash {}
set k
@@ -3359,7 +3358,7 @@ test range-2.1 {foreach range test without obj reuse} {
test range-2.2 {range element shimmering test} {
set k {}
foreach x [range 0 10] {
- append k [llength $x]
+ append k [llength $x]
}
set k
} {1111111111}
@@ -3385,12 +3384,40 @@ test range-5.0 {lindex llength range test} {
set trash {}
set r [range 100]
for {set i 0} {$i < [llength $r]} {incr i 2} {
- incr k [expr {[lindex $r $i]*[lindex $r [expr {$i+1}]]}]
+ incr k [expr {[lindex $r $i]*[lindex $r [expr {$i+1}]]}]
}
set trash {}
set k
} {164150}
+test range-6.1 {range} -body {
+ range
+} -returnCodes error -result {wrong # args: should be "range ?start? end ?step?"}
+
+test range-6.2 {range} -body {
+ range foo
+} -returnCodes error -result {expected integer but got "foo"}
+
+test range-6.3 {range} -body {
+ range 2 bar
+} -returnCodes error -result {expected integer but got "bar"}
+
+test range-6.4 {range} -body {
+ range 2 4 foo
+} -returnCodes error -result {expected integer but got "foo"}
+
+test range-6.5 {range} -body {
+ range 10 0
+} -returnCodes error -result {Invalid (infinite?) range specified}
+
+test range-6.6 {range} -body {
+ range 2 4 0
+} -returnCodes error -result {Invalid (infinite?) range specified}
+
+test range-6.7 {range} -body {
+ range 2 4 -2
+} -returnCodes error -result {Invalid (infinite?) range specified}
+
################################################################################
# SCOPE
################################################################################
@@ -3487,6 +3514,30 @@ test env-1.3 {env} -body {
} -returnCodes error -result {environment variable "DOES_NOT_EXIST" does not exist}
################################################################################
+# READDIR
+################################################################################
+test readdir-1.1 {readdir usage} -body {
+ readdir
+} -returnCodes error -result {wrong # args: should be "readdir ?-nocomplain? dirPath"}
+
+test readdir-1.2 {readdir basic} -body {
+ expr {"jim.test" in [readdir [file dirname [info script]]]}
+} -result {1}
+
+test readdir-1.3 {readdir basic} -body {
+ expr {"jim.test" in [readdir -nocomplain [file dirname [info script]]]}
+} -result {1}
+
+test readdir-1.4 {readdir errors} -body {
+ readdir nonexistent
+} -returnCodes error -result {No such file or directory}
+
+test readdir-1.4 {readdir -nocomplain} -body {
+ readdir -nocomplain nonexistent
+} -result {}
+
+
+################################################################################
# JIM REGRESSION TESTS
################################################################################
test regression-1.0 {Rename against procedures with static vars} {
diff --git a/tests/jiminterp.test b/tests/jiminterp.test
new file mode 100644
index 0000000..5273409
--- /dev/null
+++ b/tests/jiminterp.test
@@ -0,0 +1,27 @@
+source [file dirname [info script]]/testing.tcl
+
+needs constraint jim
+needs cmd interp
+
+test interp-1.0 {interp bad args} -body {
+ interp arg
+} -returnCodes error -result {wrong # args: should be "interp"}
+
+test interp-1.1 {interp alias} {
+ set i [interp]
+ $i alias subincr incr
+ $i eval { set x 0 }
+ $i eval { subincr x }
+ $i eval { subincr x }
+} {2}
+
+test interp-1.2 {interp alias delete} {
+ $i eval { rename subincr "" }
+} {}
+
+test interp-1.3 {interp delete } {
+ $i alias subincr2 incr
+ $i delete
+} {}
+
+testreport
diff --git a/tests/jimsh.test b/tests/jimsh.test
new file mode 100644
index 0000000..eabd248
--- /dev/null
+++ b/tests/jimsh.test
@@ -0,0 +1,40 @@
+source [file dirname [info script]]/testing.tcl
+
+needs constraint jim
+
+test jimsh-1.1 {jimsh --help} -body {
+ exec [info nameofexecutable] --help
+} -match glob -result {jimsh version *Usage: *}
+
+test jimsh-1.2 {jimsh -} {
+ exec [info nameofexecutable] - << {puts $(1 + 2)}
+} {3}
+
+test jimsh-1.3 {jimsh - arg list} jim {
+ exec [info nameofexecutable] - arg list << {puts [join $argv]}
+} {arg list}
+
+test jimsh-1.4 {jimsh -e} {
+ exec [info nameofexecutable] -e {expr {4 + 5}}
+} {9}
+
+test jimsh-1.4 {jimsh -e with args} {
+ exec [info nameofexecutable] -e {set argv} arg1 arg2
+} {arg1 arg2}
+
+test jimsh-1.5 {jimsh --version} {
+ exec [info nameofexecutable] --version
+} [info version]
+
+test jimsh-1.6 {jimsh -e with error} -body {
+ exec [info nameofexecutable] -e blah
+} -returnCodes error -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
+. }
+
+testreport
diff --git a/tests/load.test b/tests/load.test
new file mode 100644
index 0000000..140194f
--- /dev/null
+++ b/tests/load.test
@@ -0,0 +1,109 @@
+source [file dirname [info script]]/testing.tcl
+
+needs cmd load interp
+
+# In order to test loadable modules we need a working build-jim-ext
+# (from the same directory as jimsh).
+# If we don't have that, just skip these tests.
+
+set buildjimext [file join [file dirname [info nameofexecutable]] build-jim-ext]
+# loadtest.c is in the same directory as this script
+set src [file join [file dirname [info script]] loadtest.c]
+
+set skip 1
+if {[file exec $buildjimext]} {
+ set skip [catch {
+ exec $buildjimext $src
+ }]
+ if {!$skip && ![file exists loadtest.so]} {
+ set skip 1
+ }
+}
+if {$skip} {
+ skiptest " (no working build-jim-ext)"
+}
+
+test load-1.0 {load usage} -body {
+ load
+} -returnCodes error -result {wrong # args: should be "load libraryFile"}
+
+# Now everything is done in a child interpreter so that
+# because loadable modules only get unloaded on interpreter exit
+test load-1.1 {load initial} {
+ set interp [interp]
+ $interp eval {exists -command loadtest}
+} {0}
+
+test load-1.2 {create loadable extension} -body {
+ exec $buildjimext $src
+ file exists loadtest.so
+} -result {1}
+
+test load-1.3 {load dynamic extension} -body {
+ $interp eval {
+ load loadtest.so
+ exists -command loadtest
+ }
+} -result {1}
+
+test load-1.4 {run dynamic extension command} -body {
+ $interp eval {
+ loadtest test abc
+ }
+} -result {abc}
+
+test load-1.5 {load invalid dynamic extension} -body {
+ $interp eval {
+ load nonexistent
+ }
+} -returnCodes error -match glob -result {error loading extension "nonexistent": *}
+
+$interp delete
+
+test load-1.6 {load via package require} {
+ set interp [interp]
+ $interp eval {
+ lappend auto_path [pwd]
+ package require loadtest
+ exists -command loadtest
+ }
+} {1}
+
+$interp delete
+
+test load-2.1 {loadable extension with full path} -body {
+ set interp [interp]
+ exec $buildjimext $src
+ $interp eval {
+ load [pwd]/loadtest.so
+ loadtest test def
+ }
+} -result {def} -cleanup {
+ $interp delete
+}
+
+test load-2.2 {loadable extension without extension} -body {
+ set interp [interp]
+ file rename loadtest.so loadtest
+ $interp eval {
+ load loadtest
+ loadtest test def
+ }
+} -result {def} -cleanup {
+ $interp delete
+ file delete loadtest
+}
+
+test load-2.1 {loadable extension with no entrypoint} -body {
+ set interp [interp]
+ exec $buildjimext --notest -DNO_ENTRYPOINT $src
+ $interp eval {
+ load loadtest.so
+ }
+} -returnCodes error -result {No Jim_loadtestInit symbol found in extension loadtest.so} -cleanup {
+ $interp delete
+}
+
+file delete loadtest.so
+
+testreport
diff --git a/tests/loadtest.c b/tests/loadtest.c
new file mode 100644
index 0000000..138e403
--- /dev/null
+++ b/tests/loadtest.c
@@ -0,0 +1,36 @@
+#include <jim.h>
+#include <jim-subcmd.h>
+
+static int loadtest_cmd_test(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
+{
+ Jim_SetResult(interp, argv[0]);
+ return JIM_OK;
+}
+
+static const jim_subcmd_type loadtest_command_table[] = {
+ { "test",
+ "arg",
+ loadtest_cmd_test,
+ 1,
+ 1,
+ },
+ { NULL }
+};
+
+static int loadtest_cmd(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
+{
+ return Jim_CallSubCmd(interp, Jim_ParseSubCmd(interp, loadtest_command_table, argc, argv), argc, argv);
+}
+
+#ifndef NO_ENTRYPOINT
+int Jim_loadtestInit(Jim_Interp *interp)
+{
+ if (Jim_PackageProvide(interp, "loadtest", "1.0", JIM_ERRMSG)) {
+ return JIM_ERR;
+ }
+
+ Jim_CreateCommand(interp, "loadtest", loadtest_cmd, 0, 0);
+
+ return JIM_OK;
+}
+#endif
diff --git a/tests/pack.test b/tests/pack.test
new file mode 100644
index 0000000..a01669a
--- /dev/null
+++ b/tests/pack.test
@@ -0,0 +1,118 @@
+source [file dirname [info script]]/testing.tcl
+
+needs cmd pack
+
+test pack-1.1 {pack usage} -body {
+ pack
+} -returnCodes error -result {wrong # args: should be "pack varName value -intle|-intbe|-floatle|-floatbe|-str bitwidth ?bitoffset?"}
+
+test pack-1.2 {pack invalid type} -body {
+ pack a 1 -badopt 8
+} -returnCodes error -result {bad option "-badopt": must be -floatbe, -floatle, -intbe, -intle, or -str}
+
+test pack-1.3 {pack bad width} -body {
+ pack a 1 -intbe badint
+} -returnCodes error -result {expected integer but got "badint"}
+
+test pack-1.4 {pack bad width} -body {
+ pack a 1 -intbe -5
+} -returnCodes error -result {bad bitwidth: -5}
+
+test pack-1.5 {pack bad offset} -body {
+ pack a 1 -intbe 5 badint
+} -returnCodes error -result {expected integer but got "badint"}
+
+test pack-1.6 {pack bad offset} -body {
+ pack a 1 -intbe 5 -6
+} -returnCodes error -result {bad bitoffset: -6}
+
+test pack-2.1 {pack basic} {
+ unset -nocomplain a
+ pack a 65 -intle 8
+ set a
+} {A}
+
+test pack-2.2 {pack append} {
+ pack a 66 -intle 8 8
+ set a
+} {AB}
+
+test pack-2.3 {pack after end pads with null} {
+ pack a 67 -intle 8 24
+ set a
+} "AB\x00C"
+
+test pack-2.4 {pack replace} {
+ pack a 68 -intle 8 16
+ set a
+} "ABDC"
+
+test pack-2.5 {pack str after end pads with null} {
+ pack a ghi -str 24 40
+ set a
+} "ABDC\x00ghi"
+
+test pack-2.6 {pack str width > string length} {
+ set a {}
+ pack a ab -str 32
+ set a
+} "ab\x00\x00"
+
+set badvar {a}
+
+test pack-2.7 {pack bad set} -body {
+ pack badvar(a) 32 -intle 8
+} -returnCodes error -result {can't set "badvar(a)": variable isn't array}
+
+test pack-2.8 {pack bad set} -body {
+ pack bad\x00var 32 -intle 8
+} -returnCodes error -result {variable name contains embedded null}
+
+test unpack-1.1 {unpack usage} -body {
+ unpack
+} -returnCodes error -result {wrong # args: should be "unpack binvalue -intbe|-intle|-uintbe|-uintle|-floatbe|-floatle|-str bitpos bitwidth"}
+
+test unpack-1.2 {unpack invalid type} -body {
+ unpack abc -badopt 0 8
+} -returnCodes error -result {bad option "-badopt": must be -floatbe, -floatle, -intbe, -intle, -str, -uintbe, or -uintle}
+
+test unpack-1.3 {unpack bad width} -body {
+ unpack abc -intle 0 badint
+} -returnCodes error -result {expected integer but got "badint"}
+
+test unpack-1.4 {unpack bad width} -body {
+ # Poor message
+ unpack abc -intle 0 -5
+} -returnCodes error -result {int field is too wide: -5}
+
+test unpack-1.5 {unpack bad offset} -body {
+ unpack abc -intle badint 8
+} -returnCodes error -result {expected integer but got "badint"}
+
+test unpack-1.6 {unpack bad offset} {
+ # Should be an error
+ unpack abc -intle -6 8
+} 0
+
+test unpack-1.7 {unpack str not on byte boundary offset} -body {
+ unpack abc -str 5 8
+} -returnCodes error -result {string field is not on a byte boundary}
+
+test unpack-1.8 {unpack float bad width} -body {
+ unpack abc -floatbe 0 24
+} -returnCodes error -result {float field has bad bitwidth: 24}
+
+test unpack-2.1 {unpack str width past end} -body {
+ unpack abc -str 16 16
+} -result c
+
+test unpack-2.2 {unpack intle} -body {
+ format 0x%04x [unpack \x01\x02\x03 -intle 8 16]
+} -result 0x0302
+
+test unpack-2.3 {unpack int width past end} -body {
+ unpack \x01\x02\x03 -intle 16 16
+} -result 3
+
+
+testreport
diff --git a/tests/package.test b/tests/package.test
new file mode 100644
index 0000000..940ed74
--- /dev/null
+++ b/tests/package.test
@@ -0,0 +1,16 @@
+source [file dirname [info script]]/testing.tcl
+
+needs constraint jim
+needs cmd package
+
+test package-1.1 {provide} -body {
+ package provide new-package-name
+ expr {"new-package-name" in [package names]}
+} -result 1
+
+test package-1.2 {provide, duplicate} -body {
+ package provide new-package-name
+} -returnCodes error -result {package "new-package-name" was already provided}
+
+testreport
+
diff --git a/tests/posix.test b/tests/posix.test
new file mode 100644
index 0000000..74423cb
--- /dev/null
+++ b/tests/posix.test
@@ -0,0 +1,37 @@
+source [file dirname [info script]]/testing.tcl
+
+needs constraint jim
+testCmdConstraints os.getids os.gethostname os.uptime os.fork
+
+test posix-1.1 {os.getids usage} -body {
+ os.getids blah
+} -returnCodes error -result {wrong # args: should be "os.getids"}
+
+test posix-1.2 {os.getids} -body {
+ set uid [exec id -u]
+ set d [os.getids]
+ if {$d(uid) != $uid} {
+ error "os.getids uid=$d(uid) not match system $uid"
+ }
+} -result {}
+
+
+test posix-1.4 {os.uptime} -body {
+ string is integer -strict [os.uptime]
+} -result {1}
+
+test posix-1.5 {os.gethostname usage} -body {
+ os.gethostname blah
+} -returnCodes error -result {wrong # args: should be "os.gethostname"}
+
+test posix-1.6 {os.gethostname} -body {
+ if {[exec hostname] ne [os.gethostname]} {
+ error "os.gethostname did not match system hostname"
+ }
+} -result {}
+
+test posix-1.7 {os.fork usage} -body {
+ os.fork extra args
+} -returnCodes error -result {wrong # args: should be "os.fork"}
+
+testreport
diff --git a/tests/proc.test b/tests/proc.test
index 50c9674..462b713 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -246,7 +246,9 @@ test proc-old-5.3 {error conditions} {
list [catch {proc tproc b c d e} msg]
} {1}
-
+test proc-5.4 {proc double args} -body {
+ proc a {args args} {}
+} -returnCodes error -result {'args' specified more than once}
test proc-old-5.6 {error conditions} {
list [catch {proc tproc {{} y} {return foo}} msg] $msg
diff --git a/tests/regcount.test b/tests/regcount.test
index 5c1469e..dd8119f 100644
--- a/tests/regcount.test
+++ b/tests/regcount.test
@@ -44,8 +44,9 @@ foreach {pat str exp} {
a{1,2}? baaaad a
a{3,4}? baaaad aaa
a{5,6}? baaaad {}
+ (a|b){3,4}?def baaaad {}
{\d{1,3}} 239 239
- (aa|bb)?c xabbaac {aac aa}
+ (aa|bb)?cdef xcdabbaacdef {aacdef aa}
(a|y)+ bac {a a}
(a|y){1,} bac {a a}
(a|y)* bac {{} {}}
@@ -84,6 +85,13 @@ foreach {pat str exp} {
(a|y){5,6}? baaaad {}
{[[:alpha:]]+} _bcd56_ef bcd
{[[:alnum:]]+} _bcd56_ef bcd56
+ {[[:blank:]]+} "_b \t\n6cAF" "{ \t}"
+ {[[:upper:]]+} "_b \t\n6cAF" {AF}
+ {[[:lower:]]+} "_b \t\n6cAF" {b}
+ {[[:cntrl:]]+} _bcd\x04z56_ef "\x04"
+ {[[:print:]]+} "\v _b \t\n6cAF" {{ _b }}
+ {[[:graph:]]+} " _,b \t\n6cAF" {_,b}
+ {[[:punct:]]+} bcd56_,ef _,
{[\w]+} :_bcd56_ef _bcd56_ef
{[[:space:]]+} "_bc \t\r\n\f\v_" "{ \t\r\n\f\v}"
{[\x41-\x43]+} "_ABCD_" ABC
@@ -96,6 +104,8 @@ foreach {pat str exp} {
####((a*)*b)*b aaaaaaaaaaaaaaaaaaaaaaaaab {b {} {}}
####(a*)* aab {aa {}}
{^([^:=]*)(:)?(=)?$} version {version version {} {}}
+ {\Aab.} abc,abd abc
+ {de.\Z} def,deh,dei dei
} {
if {[string match #* $pat]} {
continue
diff --git a/tests/regexp.test b/tests/regexp.test
index 03fdcbe..e372fbd 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -661,6 +661,88 @@ test regexp-21.15 {Replace literal backslash} {
set value
} "\\abc\\def"
+test regexp-22.1 {char range} {
+ regexp -all -inline {[a-c]+} "defaaghbcadfbaacccd"
+} {aa bca baaccc}
+
+# Tcl doesn't like this
+test regexp-22.2 {reversed char range} jim {
+ regexp -all -inline {[c-a]+} "defaaghbcadfbaacccd"
+} {aa bca baaccc}
+
+# Note that here the hex escapes are interpreted by regexp, not by Tcl
+test regexp-22.3 {hex digits} {
+ regexp -all -inline {[\x6a-\x6c]+} "jlaksdjflkwueorilkj"
+} {jl k j lk lkj}
+
+test regexp-22.4 {uppercase hex digits} {
+ regexp -all -inline {[\x6A-\x6C]+} "jlaksdjflkwueorilkj"
+} {jl k j lk lkj}
+
+# Below \x9X will be treated as \x9 followed by X
+test regexp-22.5 {invalid hex digits} {
+ regexp -all -inline {[\x9X\x6C]+} "jla\tX6djflyw\tueorilkj"
+} [list l \tX l \t l]
+
+test regexp-22.6 {unicode hex digits} jim {
+ regexp -all -inline {[\u{41}-\u{00043}]+} "AVBASDFBABDFBAFBAFA"
+} {A BA BAB BA BA A}
+
+# \u{X41} is treated as u { X 41 }
+test regexp-22.7 {unicode hex digits with invalid exscape} jim {
+ regexp -all -inline {[\u{X41}]+} "uVBAX{SD4B1}DFBAFBAFA"
+} {u X\{ 4 1\}}
+
+test regexp-22.8 {unicode hex digits} {
+ regexp -all -inline {[\u0041-\u0043]+} "AVBASDFBABDFBAFBAFA"
+} {A BA BAB BA BA A}
+
+test regexp-22.9 {\U unicode hex digits} {
+ regexp -all -inline {[\U00000041-\U00000043]+} "AVBASDFBABDFBAFBAFA"
+} {A BA BAB BA BA A}
+
+test regexp-22.10 {Various char escapes} {
+ set result {}
+ foreach match [regexp -all -inline {[\e\f\v\t\b]+} "A\f\vBB\b\tC\x1BG"] {
+ set chars {}
+ foreach c [split $match ""] {
+ scan $c %c char
+ lappend chars $char
+ }
+ lappend result [join $chars ,]
+ }
+ join $result |
+} {12,11|8,9|27}
+
+test regexp-22.11 {backslash as last char} {
+ regexp -all -inline "\[a\\" "ba\\d\[ef"
+} "a\ \\\\"
+
+# Probably should be an error
+test regexp-22.12 {missing closing bracket} {
+ regexp -all -inline {[abc} "abcdefghi"
+} {a b c}
+
+test regexp-22.13 {empty alternative} {
+ regexp -all -inline {a(a|b|)c} "aacbacbaa"
+} {aac a ac {}}
+
+test regexp-22.14 {] in set} {
+ regexp -all -inline {[]ab]+} "aac\[ba\]cbaa"
+} {aa ba\] baa}
+
+test regexp-22.15 {- in set} {
+ regexp -all -inline {[-ab]+} "aac\[ba\]cb-aa"
+} {aa ba b-aa}
+
+test regexp-22.16 {\s in set} {
+ regexp -all -inline {[\sa]+} "aac\[b a\]c\tb-aa"
+} [list aa " a" \t aa]
+
+test regexp-22.17 {\d in set} {
+ regexp -all -inline {[a\d]+} "a0ac\[b a\]44c\tb-1aa7"
+} {a0a a 44 1aa7}
+
# Tests resulting from bugs reported by users
test reg-31.1 {[[:xdigit:]] behaves correctly when followed by [[:space:]]} {
set str {2:::DebugWin32}
diff --git a/tests/regexp2.test b/tests/regexp2.test
index 1aee8cd..936224d 100644
--- a/tests/regexp2.test
+++ b/tests/regexp2.test
@@ -494,6 +494,15 @@ test regexpComp-10.3 {newline sensitivity in regsub} {
# list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
# }
#} "1 {da\nb123\nxb}"
+test regexpComp-10.6 {\Z only matching end of string with -line} {
+ evalInProc {
+ set foo xxx
+ list [regsub -line {^a.*b\Z} "dabc\ncaxyb\naxb" 123 foo] $foo
+ }
+} "1 {dabc\ncaxyb\n123}"
+test regexpComp-10.7 {\A only matching beginning of string with -line} {
+ regexp -all -inline -line {\Aab.} abc\nabd
+} {abc}
test regexpComp-11.1 {regsub errors} {
evalInProc {
@@ -622,11 +631,11 @@ test regexpComp-16.3 {regsub -start} {
catch {unset x}
list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
-#test regexpComp-16.4 {regsub -start, \A behavior} {
-# set out {}
-# lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
-# lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
-#} {5 /a/b/c/d/e 3 ab/c/d/e}
+test regexpComp-16.4 {regsub -start, \A behavior} tcl {
+ set out {}
+ lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
+ lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
+} {5 /a/b/c/d/e 3 ab/c/d/e}
test regexpComp-16.5 {regexp -start with utf8} utf8 {
regexp -inline -start 1 . \u0442\u0435\u0441\u0442
} \u0435
@@ -634,6 +643,14 @@ test regexpComp-16.6 {regexp -start with utf8} utf8 {
regsub -start 1 . \u0442\u0435\u0441\u0442 x
} \u0442x\u0441\u0442
+test regexpComp-16.7 {regexp -start with \A} {
+ regsub -start 1 {\Aabc} deabc -
+} {deabc}
+
+test regexpComp-16.7 {regexp -start with \A} {
+ regsub -start 1 {\Aabc} dabc -
+} {d-}
+
test regexpComp-17.1 {regexp -inline} {
regexp -inline b ababa
} {b}
diff --git a/tests/signal.test b/tests/signal.test
index e212501..4eb633d 100644
--- a/tests/signal.test
+++ b/tests/signal.test
@@ -95,4 +95,113 @@ test signal-1.8 "try/signal" try {
list [expr {$i in {3 4 5}}] $msg
} {1 SIGALRM}
+test signal-1.9 {throw an ignored signal} {
+ signal ignore SIGTERM
+ signal throw SIGTERM
+ signal check -clear SIGTERM
+} {SIGTERM}
+
+test signal-1.10 {throw with no signal} try {
+ # With no arg, signal throw means signal throw SIGINT
+ try -signal {
+ signal throw
+ } on signal msg {
+ }
+ set msg
+} SIGINT
+
+test signal-2.1 {bad signal} -body {
+ signal handle NONEXISTENT
+} -returnCodes error -result {unknown signal NONEXISTENT}
+
+test signal-2.2 {bad signal} -body {
+ signal handle 999999
+} -returnCodes error -result {unknown signal 999999}
+
+test signal-2.3 {signal by number} {
+ signal handle 2
+ signal default 2
+} {}
+
+test signal-2.4 {signal block} {
+ signal block SIGINT
+ signal handle SIGINT
+ signal default SIGINT
+} {}
+
+# should complain about unknown signal
+test signal-2.5 {signal check invalid} -body {
+ signal check NONEXISTENT
+} -returnCodes error -result {wrong # args: should be "signal check ?-clear? ?signals ...?"}
+
+# should complain about unknown signal
+test signal-2.6 {signal check invalid num} -body {
+ signal check 999999
+} -returnCodes error -result {wrong # args: should be "signal check ?-clear? ?signals ...?"}
+
+test signal-2.7 {signal throw invalid} -body {
+ signal throw NONEXISTENT
+} -returnCodes error -result {unknown signal NONEXISTENT}
+
+test signal-2.8 {signal throw invalid num} -body {
+ signal throw 999999
+} -returnCodes error -result {unknown signal 999999}
+
+test signal-2.9 {signal list} {
+ expr {"SIGINT" in [signal default]}
+} {1}
+
+test alarm-1.1 {alarm usage} -body {
+ alarm
+} -returnCodes error -result {wrong # args: should be "alarm seconds"}
+
+test alarm-1.2 {alarm usage} -body {
+ alarm too many args
+} -returnCodes error -result {wrong # args: should be "alarm seconds"}
+
+test alarm-1.3 {alarm usage} -body {
+ alarm badnum
+} -returnCodes error -result {expected floating-point number but got "badnum"}
+
+test alarm-1.4 {alarm seconds} {
+ alarm 2
+ alarm 0
+} {}
+
+test sleep-1.1 {sleep usage} -body {
+ sleep
+} -returnCodes error -result {wrong # args: should be "sleep seconds"}
+
+test sleep-1.2 {sleep usage} -body {
+ sleep too many args
+} -returnCodes error -result {wrong # args: should be "sleep seconds"}
+
+test sleep-1.3 {sleep usage} -body {
+ sleep badnum
+} -returnCodes error -result {expected floating-point number but got "badnum"}
+
+test kill-1.1 {kill usage} -body {
+ kill
+} -returnCodes error -result {wrong # args: should be "kill ?SIG|-0? pid"}
+
+test kill-1.2 {kill usage} -body {
+ kill too many args
+} -returnCodes error -result {wrong # args: should be "kill ?SIG|-0? pid"}
+
+test kill-1.3 {kill bad signal} -body {
+ kill NONEXISTENT [pid]
+} -returnCodes error -result {unknown signal NONEXISTENT}
+
+test kill-1.4 {kill -0} {
+ kill -0 [pid]
+} {}
+
+test kill-1.5 {kill 0 pid} {
+ kill 0 [pid]
+} {}
+
+test kill-1.6 {kill to invalid process} -body {
+ kill 0 9999999
+} -returnCodes error -result {kill: Failed to deliver signal}
+
testreport
diff --git a/tests/tty.test b/tests/tty.test
index 0736947..a2606ab 100644
--- a/tests/tty.test
+++ b/tests/tty.test
@@ -13,12 +13,29 @@ test tty-1.1 {tty status} {
dict exists $dict output
} 1
-foreach {id param value} {
- tty-1.2 output raw
- tty-1.3 input raw
- tty-1.4 handshake rtscts
+test tty-1.2 {tty bad param} -body {
+ stdout tty bad value
+} -returnCodes error -result {bad setting "bad": must be baud, data, echo, handshake, input, output, parity, stop, vmin, or vtime}
+
+test tty-1.3 {tty bad baud} -body {
+ stdout tty baud 12345
+} -returnCodes error -result {bad value for baud: 12345}
+
+test tty-1.4 {tty bad fd} -body {
+ set f [open [file tempfile] w]
+ $f tty
+} -returnCodes error -result {Inappropriate ioctl for device} -cleanup {
+ $f close
+}
+
+
+set n 0
+foreach {param value} {
+ output raw
+ input raw
+ handshake rtscts
} {
- test $id "tty setting $param" -setup {
+ test tty-1.[incr n] "tty setting $param" -setup {
set savetty [stdout tty]
} -body "stdout tty $param $value; dict get \[stdout tty\] $param" \
-result $value -cleanup {
@@ -26,19 +43,14 @@ foreach {id param value} {
}
}
-test tty-1.4 {tty setting} -body {
- stdout tty output bad
-} -returnCodes error -result {bad value for output: bad}
-
-test tty-1.4 {tty setting} -body {
- stdout tty bad value
-} -returnCodes error -result {bad setting "bad": must be baud, data, echo, handshake, input, output, parity, stop, vmin, or vtime}
-
-test tty-1.5 {tty bad fd} -body {
- set f [open [file tempfile] w]
- $f tty
-} -returnCodes error -result {Inappropriate ioctl for device} -cleanup {
- $f close
+set n 0
+foreach param {output input handshake baud stop data vmin vtime} {
+ test tty-2.[incr n] "tty bad setting $param" -setup {
+ set savetty [stdout tty]
+ } -body "stdout tty $param bad" \
+ -returnCodes error -result "bad value for $param: bad" -cleanup {
+ stdout tty $savetty
+ }
}
testreport
diff --git a/tests/utf8.test b/tests/utf8.test
index 74a5aa8..7b655da 100644
--- a/tests/utf8.test
+++ b/tests/utf8.test
@@ -149,4 +149,24 @@ test utf8-8.4 {Longer sequences} {
string length \u12000
} 2
+test utf8-8.5 {\U} jim {
+ set x \U000000b5
+} \ub5
+
+test utf8-8.6 {\u invalid} {
+ set x "\u{0000000b5}"
+} "u{0000000b5}"
+
+test utf8-9.1 {string totitle} {
+ string totitle \u01c4-test
+} "\u01c5-test"
+
+test utf8-9.2 {string totitle} {
+ string totitle \u01c5-test
+} "\u01c5-test"
+
+test utf8-9.3 {string totitle} {
+ string totitle abc-\u01c4
+} "Abc-\u01c6"
+
testreport