? 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
-
-
-
-
-
-
-
-
-
-
-
 
