diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | library/init.tcl | 48 | ||||
| -rw-r--r-- | tests/init.test | 64 |
3 files changed, 100 insertions, 19 deletions
@@ -1,3 +1,10 @@ +2001-04-06 Don Porter <dgp@users.sourceforge.net> + + * library/init.tcl: + * tests/init.test: Modified processing of $::errorInfo by + [unknown] when the auto-loaded command throws an error to better + cover the tracks of auto-loading. [Bug 219280, Patch 403551] + 2001-04-06 Donal K. Fellows <fellowsd@cs.man.ac.uk> * doc/read.n: Added section on "USE WITH SERIAL PORTS" to resolve diff --git a/library/init.tcl b/library/init.tcl index b6ba69f..644fba3 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# RCS: @(#) $Id: init.tcl,v 1.44 2000/12/11 04:17:38 dgp Exp $ +# RCS: @(#) $Id: init.tcl,v 1.45 2001/04/06 17:57:31 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -203,14 +203,48 @@ proc unknown args { 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). + # Compute stack trace contribution from the [uplevel]. + # Note the dependence on how Tcl_AddErrorInfo, etc. + # construct the stack trace. # - - 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]..." + } + append cinfo "\"\n (\"uplevel\" body line 1)" + append cinfo "\n invoked from within" + append cinfo "\n\"uplevel 1 \$args\"" + # + # Try each possible form of the stack trace + # and trim the extra contribution from the matching case + # + set expect "$msg\n while executing\n\"$cinfo" + if {$errorInfo eq $expect} { + # + # The stack has only the eval from the expanded command + # Do not generate any stack trace here. + # + return -code error -errorcode $errorCode $msg + } + # + # 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 {$errorInfo ne "$einfo$expect"} { + error "Tcl bug: unexpected stack trace in \"unknown\"" {} \ + [list CORE UNKNOWN BADTRACE $expect $errorInfo"] + } return -code error -errorcode $errorCode \ - -errorinfo $new $msg + -errorinfo $einfo $msg } else { return -code $code $msg } diff --git a/tests/init.test b/tests/init.test index 46f4429..c31412b 100644 --- a/tests/init.test +++ b/tests/init.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: init.test,v 1.7 2000/05/03 00:14:36 hobbs Exp $ +# RCS: @(#) $Id: init.test,v 1.8 2001/04/06 17:57:32 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -149,21 +149,61 @@ test init-3.0 {random stuff in the auto_index, should still work} { 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 - - - - - - - - - - - |