Index: library/init.tcl
===================================================================
RCS file: /cvsroot/tcl/tcl/library/init.tcl,v
retrieving revision 1.44
diff -u -r1.44 init.tcl
--- library/init.tcl 2000/12/11 04:17:38 1.44
+++ library/init.tcl 2001/04/06 07:21:07
@@ -200,19 +200,51 @@
if {$msg} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
- set code [catch {uplevel 1 $args} msg]
+ namespace eval ::tcl {variable __tmpmsg ""}
+ upvar 0 ::tcl::__tmpmsg tmpmsg
+ set code [uplevel 1 [list catch $args ::tcl::__tmpmsg]]
if {$code == 1} {
#
- # Strip the last five lines off the error stack (they're
- # from the "uplevel" command).
+ # Compute stack trace contribution from the "eval" (catch)
+ # of $args
#
-
- set new [split $errorInfo \n]
- set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
+ set cinfo $args
+ if {[string length $cinfo] > 150} {
+ set cinfo "[string range $cinfo 0 149]..."
+ }
+ #
+ # Try each possible form of the stack trace
+ # and trim the extra contribution from the matching case
+ #
+ set expect "$tmpmsg\n while executing\n\"$cinfo\""
+ if {[string compare $errorInfo $expect] == 0} {
+ #
+ # The stack has only the eval from the expanded command
+ # Do not generate any stack trace here.
+ #
+ return -code error -errorcode $errorCode $tmpmsg
+ }
+ #
+ # Stack trace is nested, trim off just the contribution
+ # from the extra "eval" of $args due to the "catch" above.
+ #
+ set expect "\n invoked from within\n\"$cinfo\""
+ set exlen [string length $expect]
+ set eilen [string length $errorInfo]
+ set i [expr {$eilen - $exlen - 1}]
+ set einfo [string range $errorInfo 0 $i]
+ #
+ # For now verify that $errorInfo consists of what we are about
+ # to return plus what we expected to trim off.
+ #
+ if {[string compare $errorInfo "$einfo$expect"] != 0} {
+ error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
+ [list CORE UNKNOWN BADTRACE $expect $errorInfo"]
+ }
return -code error -errorcode $errorCode \
- -errorinfo $new $msg
+ -errorinfo $einfo $tmpmsg
} else {
- return -code $code $msg
+ return -code $code $::tcl::__tmpmsg
}
}
}
Index: tests/init.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/init.test,v
retrieving revision 1.7
diff -u -r1.7 init.test
--- tests/init.test 2000/05/03 00:14:36 1.7
+++ tests/init.test 2001/04/06 07:21:11
@@ -149,21 +149,61 @@
foo:::bar::blah
} 1
+# Tests that compare the error stack trace generated when autoloading
+# with that generated when no autoloading is necessary. Ideally they
+# should be the same.
+
+set count 0
+foreach arg {
+ c
+ {argument
+ which spans
+ multiple lines}
+ {argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack}
+ {argument which spans multiple lines
+ and is long enough to be truncated and
+" <- includes a false lead in the prune point search
+ and must be longer still to force truncation}
+ {contrived example: rare circumstance
+ where the point at which to prune the
+ error stack cannot be uniquely determined.
+ foo bar foo
+"}
+ {contrived example: rare circumstance
+ where the point at which to prune the
+ error stack cannot be uniquely determined.
+ foo bar
+"}
+ } {
+
+ test init-4.$count.0 {::errorInfo produced by [unknown]} {
+ auto_reset
+ catch {parray a b $arg}
+ set first $::errorInfo
+ catch {parray a b $arg}
+ set second $::errorInfo
+ string equal $first $second
+ } 1
+
+ test init-4.$count.1 {::errorInfo produced by [unknown]} {
+ auto_reset
+ namespace eval junk [list array set $arg [list 1 2 3 4]]
+ trace variable ::junk::$arg r \
+ "[list error [subst {Variable \"$arg\" is write-only}]] ;# "
+ catch {parray ::junk::$arg}
+ set first $::errorInfo
+ catch {parray ::junk::$arg}
+ set second $::errorInfo
+ string equal $first $second
+ } 1
+
+ incr count
}
+} ;# End of [interp eval $testInterp]
+
# cleanup
interp delete $testInterp
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
