Attachment "dgp.patch" to
ticket [403551ffff]
added by
dgp
2001-04-06 14:25:20.
? unknownStack.txt
? unknownStack2.txt
? vd.patch
? dgp.patch
? doc/FileSystem.3
? generic/tclUtil.c.patch
? library/unknownStack2.txt
? unix/demo
? unix/try.tcl
? unix/demo.c
? unix/httpd
? unix/autoMkindex.tcl
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:22:30
@@ -203,14 +203,108 @@
set code [catch {uplevel 1 $args} msg]
if {$code == 1} {
#
- # Strip the last five lines off the error stack (they're
- # from the "uplevel" command).
+ # Strip off the error stack those lines generated by
+ # the "uplevel" command.
#
-
+ # 1. Remove the last 3 lines, which are:
+ # ("uplevel" body line 1)
+ # invoked from within
+ # "uplevel 1 $args"
+ #
set new [split $errorInfo \n]
- set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
- return -code error -errorcode $errorCode \
- -errorinfo $new $msg
+ set new [join [lrange $new 0 [expr {[llength $new] - 4}]] \n]
+ #
+ # 2. Remove the quoted (and possibly truncated) $args
+ # which was passed to [uplevel] from the error stack.
+ #
+ # First strip off trailing "
+ regsub {"$} $new {} new
+ # Trailing "..." indicates truncation
+ if {![regsub {\.\.\.$} $new {} new]} {
+ #
+ # No truncation -> this is the easy case.
+ # $new ends with "\n\"$args", strip that away
+ #
+ set index [string last "\n\"$args" $new]
+ set new [string trimright [string range $new 0 $index]]
+ } elseif {[string first \n $args] == -1} {
+ #
+ # $args contains no "\n" -> also easy.
+ # The quoted and truncated $args occupies the
+ # last line of $new. Strip it off.
+ set index [string last "\n\"" $new]
+ set new [string trimright [string range $new 0 $index]]
+ } else {
+ #
+ # The tricky case
+ # $new ends with truncation of "\n\"$args", like so:
+ #
+ # $new: ________\n"|_______|
+ # | ^^^^^ |
+ # | match |
+ # | vvvvv |
+ # $args: |_______|____________
+ # ^
+ # |
+ # Need to find this/
+ # point in $new and delete from there to the end.
+ # Find all the candidates...
+ set lines [split $new \n]
+ set tailStart [expr {[llength $lines] - 1}]
+ set candidates {}
+ while {$tailStart >= 0} {
+ if {[string match \"* [lindex $lines $tailStart]]} {
+ set tail [join [lrange $lines $tailStart end] \n]
+ if {[string first $tail \"$args] == 0} {
+ lappend candidates $tailStart
+ }
+ }
+ incr tailStart -1
+ }
+ if {[llength $candidates] == 1} {
+ #
+ # There was exactly one candidate, so that's the
+ # prune point.
+ #
+ set lastKeepLine [expr {[lindex $candidates 0] - 1}]
+ set new [join [lrange $lines 0 $lastKeepLine] \n]
+ } else {
+ #
+ # In rare circumstances, there can be multiple
+ # candidates, or if something changes in the way
+ # future releases of the Tcl C library build
+ # $errorInfo, this code may fail to find any candidate.
+ # The safest thing to do in that circumstance is
+ # just give up trying to remove the evidence of the
+ # [uplevel] from the error stack and just pass the
+ # error stack on to the caller as it was passed to us.
+ #
+ # Anybody have a better idea?
+ #
+ append errorInfo \
+ "\n (evaluating \"unknown $name ...\")"
+ return -code error -errorcode $errorCode \
+ -errorinfo $errorInfo $msg
+ }
+ }
+ #
+ # 3. Remove the last remaining line, which is:
+ # while executing
+ # or some similar introductory phrase.
+ #
+ set index [string last \n $new]
+ set new [string trimright [string range $new 0 $index]]
+ #
+ # 4. Guarantee that proper introductory phrase is appended.
+ # When ($new == $msg) ==> " while executing"
+ # Otherwise ==> " invoked from within"
+ #
+ if {[string compare $new $msg] == 0} {
+ return -code error -errorcode $errorCode $msg
+ } else {
+ return -code error -errorcode $errorCode \
+ -errorinfo $new $msg
+ }
} else {
return -code $code $msg
}
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:22:34
@@ -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
-
-
-
-
-
-
-
-
-
-
-
