Improve error handling

*: Improve stack trace handling on errors
*: Add 'info source'
*: Add 'info stacktrace'
*: Add errorInfo procedure to generate a human readable stack trace
*: Add tests for stacktrace

------------------------------------------------------------------------

5 files changed, 195 insertions, 0 deletions

diff --git a/tests/Makefile b/tests/Makefile
new file mode 100644
index 0000000..1e04cdb
--- /dev/null
+++ b/tests/Makefile
@@ -0,0 +1,5 @@
+test: ../jimsh
+	@for i in *.test; do ../jimsh $$i; done
+
+../jimsh: ../jim.c
+	make -C .. all
diff --git a/tests/dummy.tcl b/tests/dummy.tcl
new file mode 100644
index 0000000..e776ef7
--- /dev/null
+++ b/tests/dummy.tcl
@@ -0,0 +1,6 @@
+# generates an error
+proc dummyproc {} {
+	error "from dummyproc"
+}
+
+dummyproc
diff --git a/tests/errors.tcl b/tests/errors.tcl
new file mode 100644
index 0000000..f6ecc32
--- /dev/null
+++ b/tests/errors.tcl
@@ -0,0 +1,58 @@
+# Package which can generate a variety of errors at known locations
+
+proc error_generator {type} {
+	switch $type \
+		badcmd {
+			bogus command called
+		} \
+		badvar {
+			incr bogus
+		} \
+		error {
+			error bogus
+		} \
+		interpbadvar {
+			set x "some $bogus text"
+		} \
+		interpbadcmd {
+			set x "some $bogus text"
+		} \
+		package {
+			package require dummy
+		} \
+		source {
+			source dummy.tcl
+		} \
+		badpackage {
+			package require bogus
+		} \
+		default {
+			puts "Unknown type=$type"
+		}
+}
+
+
+
+
+
+
+
+# line 40: Some empty lines above so that line numbers don't change
+proc error_caller {type {method call}} {
+	switch $method \
+		call {
+			error_generator $type
+		} \
+		uplevel {
+			uplevel 1 [list error_generator $type]
+		} \
+		eval {
+			eval [list error_generator $type]
+		} \
+		evalstr {
+			eval error_generator $type
+		} \
+		default {
+			puts "Unknown method=$method"
+		}
+}
diff --git a/tests/stacktrace.test b/tests/stacktrace.test
new file mode 100644
index 0000000..c23675e
--- /dev/null
+++ b/tests/stacktrace.test
@@ -0,0 +1,66 @@
+package require testing
+package require errors
+
+# Make this a proc so that the line numbers don't have to change
+proc main {} {
+	set id1 0
+	foreach type {badcmd badvar error interpbadvar interpbadcmd package source badpackage} {
+		set id2 0
+		incr id1
+		foreach method {call uplevel eval evalstr} {
+			incr id2
+			set exp ""
+			if {[info exists ::expected(err-$id1.$id2)]} {
+				set exp $::expected(err-$id1.$id2)
+			}
+			test err-$id1.$id2 "Stacktrace on error type $type, method $method" {
+				set rc [catch {error_caller $type $method} msg]
+				#puts stderr "err-$id1.$id2 $type, $method\n[errorInfo $msg]\n"
+				#puts stderr "\terr-$id1.$id2 {[list $rc $msg [info stacktrace]]}"
+
+				list $rc $msg [info stacktrace]
+			} $exp
+		}
+	}
+}
+
+set expected {
+	err-1.1 {1 {invalid command name "bogus"} {{} errors.tcl 6 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
+	err-1.2 {1 {invalid command name "bogus"} {{} errors.tcl 6 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
+	err-1.3 {1 {invalid command name "bogus"} {{} errors.tcl 6 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
+	err-1.4 {1 {invalid command name "bogus"} {{} errors.tcl 6 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
+	err-2.1 {1 {can't read "bogus": no such variable} {{} errors.tcl 9 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
+	err-2.2 {1 {can't read "bogus": no such variable} {{} errors.tcl 9 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
+	err-2.3 {1 {can't read "bogus": no such variable} {{} errors.tcl 9 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
+	err-2.4 {1 {can't read "bogus": no such variable} {{} errors.tcl 9 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
+	err-3.1 {1 bogus {{} errors.tcl 12 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
+	err-3.2 {1 bogus {{} errors.tcl 12 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
+	err-3.3 {1 bogus {{} errors.tcl 12 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
+	err-3.4 {1 bogus {{} errors.tcl 12 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
+	err-4.1 {1 {can't read "bogus": no such variable} {{} errors.tcl 15 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
+	err-4.2 {1 {can't read "bogus": no such variable} {{} errors.tcl 15 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
+	err-4.3 {1 {can't read "bogus": no such variable} {{} errors.tcl 15 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
+	err-4.4 {1 {can't read "bogus": no such variable} {{} errors.tcl 15 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
+	err-5.1 {1 {can't read "bogus": no such variable} {{} errors.tcl 18 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
+	err-5.2 {1 {can't read "bogus": no such variable} {{} errors.tcl 18 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
+	err-5.3 {1 {can't read "bogus": no such variable} {{} errors.tcl 18 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
+	err-5.4 {1 {can't read "bogus": no such variable} {{} errors.tcl 18 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
+	err-6.1 {1 {from dummyproc
+Can't find package 'dummy'} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 21 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
+	err-6.2 {1 {from dummyproc
+Can't find package 'dummy'} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 21 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
+	err-6.3 {1 {from dummyproc
+Can't find package 'dummy'} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 21 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
+	err-6.4 {1 {from dummyproc
+Can't find package 'dummy'} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 21 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
+	err-7.1 {1 {from dummyproc} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 24 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
+	err-7.2 {1 {from dummyproc} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 24 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
+	err-7.3 {1 {from dummyproc} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 24 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
+	err-7.4 {1 {from dummyproc} {{} dummy.tcl 3 dummyproc dummy.tcl 6 {} errors.tcl 24 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
+	err-8.1 {1 {Can't find package 'bogus'} {{} errors.tcl 27 error_generator errors.tcl 44 error_caller stacktrace.test 17}}
+	err-8.2 {1 {Can't find package 'bogus'} {{} errors.tcl 27 error_generator errors.tcl 47 error_caller stacktrace.test 17}}
+	err-8.3 {1 {Can't find package 'bogus'} {{} errors.tcl 27 error_generator errors.tcl 50 error_caller stacktrace.test 17}}
+	err-8.4 {1 {Can't find package 'bogus'} {{} errors.tcl 27 error_generator errors.tcl 53 error_caller stacktrace.test 17}}
+}
+
+main
diff --git a/tests/testing.tcl b/tests/testing.tcl
new file mode 100644
index 0000000..ab25575
--- /dev/null
+++ b/tests/testing.tcl
@@ -0,0 +1,60 @@
+# Uses references to automatically close files when the handle
+# can no longer be accessed.
+#
+# e.g. bio copy [autoopen infile] [autoopen outfile w]; collect
+#
+proc autoopen {filename {mode r}} {
+	set ref [ref [aio.open $filename $mode] aio lambdaFinalizer]
+	rename [getref $ref] $ref
+	return $ref
+}
+
+# And make autoopen the standard open
+rename open ""
+rename autoopen open
+
+# Hardly needed
+proc filecopy {read write} {
+	bio copy [open $read] [open $write w]
+}
+
+proc section {name} {
+	puts "-- $name ----------------"
+}
+
+set testresults {numfail 0 numpass 0 failed {}}
+
+proc test {id descr script expected} {
+    puts -nonewline "$id "
+    set rc [catch {uplevel 1 $script} result]
+	# Note that rc=2 is return
+    if {($rc == 0 || $rc == 2) && $result eq $expected} {
+		puts "OK  $descr"
+		incr ::testresults(numpass)
+    } else {
+		puts "ERR $descr"
+		puts "Expected: '$expected'"
+		puts "Got     : '$result'"
+		incr ::testresults(numfail)
+        lappend ::testresults(failed) [list $id $descr $script $expected $result]
+    }
+}
+
+proc testreport {} {
+	puts "----------------------------------------------------------------------"
+	puts "FAILED: $::testresults(numfail)"
+	foreach failed $::testresults(failed) {
+		foreach {id descr script expected result} $failed {}
+		puts "\t$id"
+	}
+	puts "PASSED: $::testresults(numpass)"
+	puts "----------------------------------------------------------------------\n"
+}
+
+proc testerror {} {
+	error "deliberate error"
+}
+
+puts [string repeat = 40]
+puts $argv0
+puts [string repeat = 40]