core: Display errors in a more "pythonesque" way

A typical error message now looks like this:

    t4.tcl:2: Error: syntax error in expression: "blah"
    Traceback (most recent call last):
      File "t4.tcl", line 14
        c 1 2 3
      File "t4.tcl", line 10, in c
        b a c
      File "t4.tcl", line 6, in b
        a A14
      File "t4.tcl", line 2, in a
        expr blah

This is produced by stackdump (that can be replaced), called by errorInfo.

Note that now stacktraces (stacktrace, info stacktrace, $opts(-errorinfo)) include
the running command at each level in addition to proc, file, line. In order for
scripts to detect this new format, a new entry tcl_platform entry has been added:
tcl_platform(stackFormat) = 4 (to signify 4 elements per frame)

In addition, instead of building the error stack frame as the stack
is unwound in response to an error, instead the entire current stack trace
is captured by stacktrace. This means that the trace extends beyond the try/catch
right back to the initial interpreter command.

The 'stacktrace' command is now implemented in C based on the same
code that generates the error stacktrace.

Signed-off-by: Steve Bennett <steveb@workware.net.au>

1 files changed, 25 insertions, 21 deletions

diff --git a/tcltest.tcl b/tcltest.tcl
index 2b8d3d8..9478dcd 100644
--- a/tcltest.tcl
+++ b/tcltest.tcl
@@ -78,11 +78,20 @@ proc skiptest {{msg {}}} {
 # Also convert proc name ::a into a for compatibility between Tcl and Jim
 proc basename-stacktrace {stacktrace} {
 	set result {}
-	foreach {p f l} $stacktrace {
-		if {[string match ::* $p]} {
+	foreach {p f l cmd} $stacktrace {
+		if {[string match *tcltest-* $f]} {
+			#break
+		}
+		if {$p eq "::tcltest::RunTest"} {
+			set p test
+		} elseif {[string match ::* $p]} {
 			set p [string range $p 2 end]
 		}
-		lappend result $p [file tail $f] $l
+		set cmd [string map [list \n \\n] $cmd]
+		if {[string length $cmd] > 20} {
+			set cmd [string range $cmd 0 20]...
+		}
+		lappend result $p [file tail $f] $l $cmd
 	}
 	return $result
 }
@@ -101,28 +110,23 @@ if {[catch {info version}]} {
 	proc testreport {} {
 		::tcltest::cleanupTests
 	}
-	proc stacktrace {{skip 0}} {
-		set trace {}
-		# Need to skip info frame 0 and this (stacktrace) level
-		incr skip 1
-		set maxlevel [info frame]
-		for {set level $skip} {$level < $maxlevel} {incr level} {
+	proc stacktrace {{skip 0} {last 0}} {
+		set frames {}
+		incr skip
+		for {set level $skip} {$level < [info frame] - $last} {incr level} {
 			set frame [info frame -$level]
-			if {[dict get $frame type] eq "source" && [dict exists $frame proc]} {
+			puts $frame
+			if {[dict get $frame type] ne "source"} {
+				continue
+			}
+			if {[dict exists $frame proc]} {
 				set proc [dict get $frame proc]
-				# make it look like it is running under Jim tcltest
-				if {$proc eq "::tcltest::RunTest"} {
-					set proc test
-				} else {
-					set proc [string range $proc 2 end]
-				}
-				lappend trace $proc [dict get $frame file] [dict get $frame line]
-				if {$proc eq "test"} {
-					break
-				}
+			} else {
+				set proc ""
 			}
+			lappend frames $proc [dict get $frame file] [dict get $frame line] [dict get $frame cmd]
 		}
-		return $trace
+		return $frames
 	}
 	return
 }