Bugs, features and tests

source fails with zero length file
unknown can't be called recursively
*: This can be useful when using unknown to dynamically load code,
   which may in turn want to dynamically load code
*: Limit it to 50 recursions though
Allow string greater/less comparison
*: Comparing two strings for order did not work
Implement file join
*: It's not to hard and is handy when working with the current dir, ""
Don't omit [unknown] completely from stack trace
*: Since we lose valuable informtion, just omit the name
Fix return from case
Turn regexp patterns into real objects
*: Thus caching the compiled regexps
Allow error to rethrow an error
Replace bcopy() with more standard memcpy()
Fixes to parray, improve errorInfo
*: errorInfo takes an optional stack trace
Add tests for rethrowing errors via errorInfo
Fix ndelay
*: Was looking at wrong param
*: Also fix usage/help for aio.socket
Package should be able to call exit
*: Currently any return from a package is changed to JIM_ERR
Line counting is incorrect for backlash newline

10 files changed, 294 insertions, 3 deletions

diff --git a/tests/Makefile b/tests/Makefile
index 1e04cdb..a97f183 100644
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -1,5 +1,5 @@
 test: ../jimsh
 	@for i in *.test; do ../jimsh $$i; done
 
-../jimsh: ../jim.c
+../jimsh: ../*.c
 	make -C .. all
diff --git a/tests/case.test b/tests/case.test
new file mode 100644
index 0000000..1973477
--- /dev/null
+++ b/tests/case.test
@@ -0,0 +1,80 @@
+source testing.tcl
+
+# Test that control structures can be implemented in a proc
+
+proc control {cond code} {
+	set iscond [uplevel 1 expr $cond]
+	#puts "$cond -> $iscond"
+	if {$iscond} {
+		set rc [catch [list uplevel 1 $code] error]
+		#puts "$code -> rc=$rc, error=$error"
+		return -code $rc $error
+	}
+}
+
+test control-1.1 "False case" {
+	control 0 bogus
+} {}
+
+test control-1.2 "Simple case" {
+	control 1 {return result}
+} {result}
+
+test control-1.3 "Break from proc" {
+	set result {}
+	foreach i {1 2 3 4 5} {
+		control {$i == 4} {break}
+		lappend result $i
+	}
+	set result
+} {1 2 3}
+
+test control-1.4 "Return from proc" {
+	foreach i {1 2 3 4 5} {
+		control {$i == 3} {return $i}
+	}
+} {3}
+
+test control-1.5 "Continue from proc" {
+	set result {}
+	foreach i {1 2 3 4 5} {
+		control {$i == 2} {continue}
+		lappend result $i
+	}
+	set result
+} {1 3 4 5}
+
+# case is a proc, but it should be able
+# to cause a return in do_case
+proc do_case {var} {
+	case $var in {
+		1 {
+			return one
+		}
+		2 {
+			return two
+		}
+		3 {
+			return 33
+		}
+		4 {
+			continue
+		}
+		5 {
+			break
+		}
+		6 {
+			return six
+		}
+	}
+	return zero
+}
+
+test control-2.1 "Return from case" {
+	set result {}
+	foreach i {0 1 2 3 4 5 6} {
+		lappend result [do_case $i]
+	}
+	set result
+} {zero one two 33}
+
diff --git a/tests/error.test b/tests/error.test
new file mode 100644
index 0000000..0bcd0da
--- /dev/null
+++ b/tests/error.test
@@ -0,0 +1,53 @@
+package require testing
+
+proc a {} {
+	error "error thrown from a"
+}
+
+proc b {} {
+	set rc [catch {a} msg]
+	if {$rc} {
+		error $msg [info stacktrace]
+	}
+}
+
+test error-1.1 "Rethrow caught error" {
+	set rc [catch {b} msg]
+	#puts stderr "error-1.1\n[errorInfo $msg]\n"
+
+	list $rc $msg [info stacktrace]
+} {1 {error thrown from a} {{} error.test 4 a error.test 8 b error.test 15}}
+
+proc c {} {
+	a
+}
+
+proc d {} {
+	c
+}
+
+proc e {} {
+	d
+}
+
+test error-1.2 "Modify stacktrace" {
+	set rc [catch {e} msg]
+	set st [info stacktrace]
+	# Now elide one entry from the stacktrace
+	#puts [errorInfo $msg]
+	set newst {}
+	foreach {p f l} $st {
+		if {$p ne "d"} {
+			lappend newst $p $f $l
+		}
+	}
+	# Now rethrow with the new stack
+	set rc [catch {error $msg $newst} msg]
+	#puts [errorInfo $msg]
+	info stacktrace
+} {{} error.test 4 a error.test 22 c error.test 26 e error.test 34}
+
+# Package should be able to invoke exit, which should exit if not caught
+test error-2.1 "Exit from package" {
+	list [catch {package require exitpackage} msg] $msg
+} {7 {Can't find package 'exitpackage'}}
diff --git a/tests/exitpackage.tcl b/tests/exitpackage.tcl
new file mode 100644
index 0000000..c292557
--- /dev/null
+++ b/tests/exitpackage.tcl
@@ -0,0 +1,3 @@
+# This package just exits
+
+exit 1
diff --git a/tests/expr.test b/tests/expr.test
new file mode 100644
index 0000000..99ef609
--- /dev/null
+++ b/tests/expr.test
@@ -0,0 +1,17 @@
+source testing.tcl
+
+section "String comparison"
+
+test expr-1.1 "Compare strings lt" {
+	expr {"V000500" < "V000405"}
+} {0}
+
+test expr-1.2 "Compare strings with embedded nulls" {
+	set s1 [format abc%cdef 0]
+	set s2 [format abc%cghi 0]
+	expr {$s1 < $s2}
+} {1}
+
+test expr-1.3 "Hex values" {
+	set mask1 [expr 0x4050 & 0x0CCC]
+} {64}
diff --git a/tests/filejoin.test b/tests/filejoin.test
new file mode 100644
index 0000000..56fe661
--- /dev/null
+++ b/tests/filejoin.test
@@ -0,0 +1,62 @@
+source testing.tcl
+
+test join-1.1 "One name" {
+	file join abc
+} {abc}
+
+test join-1.2 "One name with trailing slash" {
+	file join abc/
+} {abc}
+
+test join-1.3 "One name with leading slash" {
+	file join /abc
+} {/abc}
+
+test join-1.4 "One name with leading and trailing slash" {
+	file join /abc/
+} {/abc}
+
+test join-1.5 "Two names" {
+	file join abc def
+} {abc/def}
+
+test join-1.6 "Two names with dir trailing slash" {
+	file join abc/ def
+} {abc/def}
+
+test join-1.7 "Two names with dir leading slash" {
+	file join /abc def
+} {/abc/def}
+
+test join-1.8 "Two names with dir leading and trailing slash" {
+	file join /abc/ def
+} {/abc/def}
+
+test join-1.9 "Two names with file trailing slash" {
+	file join abc def/
+} {abc/def}
+
+test join-1.10 "Two names with file leading slash" {
+	file join abc /def
+} {/def}
+
+test join-1.11 "Two names with file leading and trailing slash" {
+	file join abc /def/
+} {/def}
+
+test join-1.12 "Two names with double slashes" {
+	file join abc/ /def
+} {/def}
+
+test join-2.1 "Dir is empty string" {
+	file join "" def
+} {def}
+
+test join-2.2 "File is empty string" {
+	file join abc ""
+} {abc}
+
+test join-2.3 "Path too long" {
+	set components [string repeat {abcdefghi } 500]
+	list [catch [concat file join $components] msg] $msg
+} {1 {Path too long}}
diff --git a/tests/lsortcmd.test b/tests/lsortcmd.test
index 3631855..fc6726b 100644
--- a/tests/lsortcmd.test
+++ b/tests/lsortcmd.test
@@ -1,4 +1,4 @@
-package require testing
+source testing.tcl
 
 section "lsort -command"
 
diff --git a/tests/regexp.test b/tests/regexp.test
new file mode 100644
index 0000000..86ba17a
--- /dev/null
+++ b/tests/regexp.test
@@ -0,0 +1,35 @@
+source testing.tcl
+
+test regexp-1.1 {effect of caching} {
+	
+    set filedata {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE}
+
+	# Note: use 2 REs because often libc will cache a single regcomp() result
+
+	# t1 should be faster because the compiled re can be cached.
+	set re1 "END_TABLE"
+	set re2 "BEGIN_TABLE"
+
+	set t1 [time {
+		regexp -inline -all $re1 $filedata
+		regexp -inline -all $re2 $filedata
+	} 10000]
+
+	# t2 should be slower since the re's need to be recompiled every time
+	set t2 [time {
+		set re1 END
+		append re1 _TABLE
+		regexp -inline -all $re1 $filedata
+		set re2 BEGIN
+		append re2 _TABLE
+		regexp -inline -all $re2 $filedata
+	} 10000]
+
+	set t1 [lindex $t1 0]
+	set t2 [lindex $t2 0]
+
+	#puts "t1=$t1, t2=$t2"
+
+	# If these two times are within 20% of each other, caching isn't working
+	expr {$t2 / $t1 < 1.2 && $t1 / $t2 < 1.2}
+} {0}
diff --git a/tests/stacktrace.test b/tests/stacktrace.test
index f7d131c..328dd49 100644
--- a/tests/stacktrace.test
+++ b/tests/stacktrace.test
@@ -22,6 +22,47 @@ proc main {} {
 			} $exp
 		}
 	}
+	proc unknown {args} {
+		error "from unknown"
+	}
+
+	test err-10.1 "Stacktrace on error from unknown (badcmd, call)" {
+		set rc [catch {error_caller badcmd call} msg]
+		#puts stderr "err-10.1\n[errorInfo $msg]\n"
+		#puts stderr "\terr-10.1 {[list $rc $msg [info stacktrace]]}"
+
+		list $rc $msg [info stacktrace]
+	} {1 {from unknown} {{} stacktrace.test 26 {} errors.tcl 6 error_generator errors.tcl 44 error_caller stacktrace.test 30}}
+
+	rename unknown ""
+
+	set a {one}
+	set b [list 1 \
+		2 \
+		3]
+	set c {two}
+	set d "list 1 
+		2 
+		3"
+	set e {three}
+	set f "list 1  \
+		2  \
+		3"
+	set g {four}
+
+	test source-1.1 "Basic line numbers" {
+		info source $a
+	} {stacktrace.test 39}
+
+	test source-1.2 "Line numbers after command with escaped newlines" {
+		info source $c
+	} {stacktrace.test 43}
+	test source-1.3 "Line numbers after string with newlines" {
+		info source $e
+	} {stacktrace.test 47}
+	test source-1.4 "Line numbers after string with escaped newlines" {
+		info source $g
+	} {stacktrace.test 51}
 }
 
 set expected {
diff --git a/tests/testing.tcl b/tests/testing.tcl
index ab25575..18bc8db 100644
--- a/tests/testing.tcl
+++ b/tests/testing.tcl
@@ -22,7 +22,7 @@ proc section {name} {
 	puts "-- $name ----------------"
 }
 
-set testresults {numfail 0 numpass 0 failed {}}
+array set testresults {numfail 0 numpass 0 failed {}}
 
 proc test {id descr script expected} {
     puts -nonewline "$id "