From c52b491011be94e796ce8c28a16249ca62256084 Mon Sep 17 00:00:00 2001 From: Steve Bennett Date: Sun, 24 Jan 2010 10:43:22 +1000 Subject: 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 ------------------------------------------------------------------------ --- tests/Makefile | 5 ++++ tests/dummy.tcl | 6 +++++ tests/errors.tcl | 58 ++++++++++++++++++++++++++++++++++++++++++++ tests/stacktrace.test | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++ tests/testing.tcl | 60 ++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 195 insertions(+) create mode 100644 tests/Makefile create mode 100644 tests/dummy.tcl create mode 100644 tests/errors.tcl create mode 100644 tests/stacktrace.test create mode 100644 tests/testing.tcl (limited to 'tests') 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] -- cgit v1.1