diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclInterp.c | 31 | ||||
| -rw-r--r-- | tests/interp.test | 89 |
3 files changed, 121 insertions, 6 deletions
@@ -1,3 +1,10 @@ +2006-10-12 Miguel Sofer <msofer@users.sf.net> + + * generic/tclInterp.c (ApplyObjCmd): + * tests/interp.test (interp-14.5-10): made [interp alias] use the + ensemble rewrite machinery to produce better error messages + [Bug 1576006] + 2006-10-12 David Gravereaux <davygrvy@pobox.com> * win/nmakehlp.c: Replaced all wnsprintf() calls with snprintf(). diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b0d03ad..6379528 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -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: tclInterp.c,v 1.62 2005/12/12 23:00:08 dkf Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.63 2006/10/12 16:24:13 msofer Exp $ */ #include "tclInt.h" @@ -1691,13 +1691,13 @@ AliasObjCmd( Tcl_Obj *CONST objv[]) /* Argument vector. */ { #define ALIAS_CMDV_PREALLOC 10 - Tcl_Interp *targetInterp; - Alias *aliasPtr; + Alias *aliasPtr = (Alias *) clientData; + Tcl_Interp *targetInterp = aliasPtr->targetInterp; int result, prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; - aliasPtr = (Alias *) clientData; - targetInterp = aliasPtr->targetInterp; + Interp *tPtr = (Interp *) targetInterp; + int isRootEnsemble = (tPtr->ensembleRewrite.sourceObjs == NULL); /* * Append the arguments to the command prefix and invoke the command in @@ -1724,6 +1724,20 @@ AliasObjCmd( for (i=0; i<cmdc; i++) { Tcl_IncrRefCount(cmdv[i]); } + + /* + * Use the ensemble rewriting machinery to insure correct error messages: + * only the source command should show, not the full target prefix. + */ + + if (isRootEnsemble) { + tPtr->ensembleRewrite.sourceObjs = objv; + tPtr->ensembleRewrite.numRemovedObjs = 1; + tPtr->ensembleRewrite.numInsertedObjs = prefc; + } else { + tPtr->ensembleRewrite.numInsertedObjs += prefc - 1; + } + if (targetInterp != interp) { Tcl_Preserve((ClientData) targetInterp); result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); @@ -1732,6 +1746,13 @@ AliasObjCmd( } else { result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); } + + if (isRootEnsemble) { + tPtr->ensembleRewrite.sourceObjs = NULL; + tPtr->ensembleRewrite.numRemovedObjs = 0; + tPtr->ensembleRewrite.numInsertedObjs = 0; + } + for (i=0; i<cmdc; i++) { Tcl_DecrRefCount(cmdv[i]); } diff --git a/tests/interp.test b/tests/interp.test index 07e758e..90cb346 100644 --- a/tests/interp.test +++ b/tests/interp.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: interp.test,v 1.49 2006/10/09 19:15:44 msofer Exp $ +# RCS: @(#) $Id: interp.test,v 1.50 2006/10/12 16:24:14 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -501,6 +501,93 @@ test interp-14.4 {testing interp alias - alias over master} { interp create a list [catch {interp alias "" a a eval} msg] $msg [info commands a] } {1 {cannot define or rename alias "a": interpreter deleted} {}} +test interp-14.5 {testing interp-alias: wrong # args} -body { + proc setx x {set x} + interp alias {} a {} setx + catch {a 1 2} + set ::errorInfo +} -cleanup { + rename setx {} + rename a {} +} -result {wrong # args: should be "a x" + while executing +"a 1 2"} +test interp-14.6 {testing interp-alias: wrong # args} -setup { + proc setx x {set x} + catch {interp delete a} + interp create a +} -body { + interp alias a a {} setx + catch {a eval a 1 2} + set ::errorInfo +} -cleanup { + rename setx {} + interp delete a +} -result {wrong # args: should be "a x" + invoked from within +"a 1 2" + invoked from within +"a eval a 1 2"} +test interp-14.7 {testing interp-alias: wrong # args} -setup { + proc setx x {set x} + catch {interp delete a} + interp create a +} -body { + interp alias a a {} setx + a eval { + catch {a 1 2} + set ::errorInfo + } +} -cleanup { + rename setx {} + interp delete a +} -result {wrong # args: should be "a x" + invoked from within +"a 1 2"} +test interp-14.8 {testing interp-alias: error messages} -body { + proc setx x {return -code error x} + interp alias {} a {} setx + catch {a 1} + set ::errorInfo +} -cleanup { + rename setx {} + rename a {} +} -result {x + while executing +"a 1"} +test interp-14.9 {testing interp-alias: error messages} -setup { + proc setx x {return -code error x} + catch {interp delete a} + interp create a +} -body { + interp alias a a {} setx + catch {a eval a 1} + set ::errorInfo +} -cleanup { + rename setx {} + interp delete a +} -result {x + invoked from within +"a 1" + invoked from within +"a eval a 1"} +test interp-14.10 {testing interp-alias: error messages} -setup { + proc setx x {return -code error x} + catch {interp delete a} + interp create a +} -body { + interp alias a a {} setx + a eval { + catch {a 1} + set ::errorInfo + } +} -cleanup { + rename setx {} + interp delete a +} -result {x + invoked from within +"a 1"} + # part 15: testing file sharing test interp-15.1 {testing file sharing} { |