diff options
| -rw-r--r-- | ChangeLog | 16 | ||||
| -rw-r--r-- | generic/tcl.h | 3 | ||||
| -rw-r--r-- | generic/tclBasic.c | 10 | ||||
| -rw-r--r-- | generic/tclInterp.c | 157 | ||||
| -rw-r--r-- | tests/interp.test | 16 | ||||
| -rw-r--r-- | tests/stack.test | 6 | ||||
| -rw-r--r-- | tests/trace.test | 29 |
7 files changed, 136 insertions, 101 deletions
@@ -1,3 +1,19 @@ +2002-07-28 Miguel Sofer <msofer@users.sourceforge.net> + + * generic/tcl.h: + * generic/tclBasic.c: added the new flag TCL_EVAL_NO_TRACEBACK to + the interface of the Tcl_Eval* functions. Modified the error + message for too many nested evaluations. + * generic/tclInterp.h: changed the Alias struct to be of variable + length and store the prefix arguments directly (instead of a + pointer to a Tcl_Obj list). Made AliasObjCmd call Tcl_EvalObjv + instead of TclObjInvoke - thus making aliases trigger execution + traces [Bug 582522]. + * tests/interp.test: + * tests/stack.test: adapted to the new error message. + * tests/trace.test: added tests for aliases firing the exec + traces. + 2002-07-27 Mo DeJong <mdejong@users.sourceforge.net> * unix/Makefile.in: Revert fix for Tcl bug 529801 diff --git a/generic/tcl.h b/generic/tcl.h index 4fc6592..d090013 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.136 2002/07/22 16:51:47 vincentdarley Exp $ + * RCS: @(#) $Id: tcl.h,v 1.137 2002/07/29 00:25:49 msofer Exp $ */ #ifndef _TCL @@ -984,6 +984,7 @@ typedef struct Tcl_DString { #define TCL_NO_EVAL 0x10000 #define TCL_EVAL_GLOBAL 0x20000 #define TCL_EVAL_DIRECT 0x40000 +#define TCL_EVAL_NO_TRACEBACK 0x80000 /* * Special freeProc values that may be passed to Tcl_SetResult (see diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a2d1dcd..ef2a29c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.65 2002/07/19 12:31:09 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.66 2002/07/29 00:25:49 msofer Exp $ */ #include "tclInt.h" @@ -2876,7 +2876,7 @@ TclInterpReady(interp) if (((iPtr->numLevels) >= iPtr->maxNestingDepth) || (TclpCheckStackSpace() == 0)) { Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many nested calls to Tcl_Eval (infinite loop?)", -1); + "too many nested evaluations (infinite loop?)", -1); return TCL_ERROR; } @@ -3101,8 +3101,8 @@ Tcl_EvalObjv(interp, objc, objv, flags) * the words that make up the command. */ int flags; /* Collection of OR-ed bits that control * the evaluation of the script. Only - * TCL_EVAL_GLOBAL is currently - * supported. */ + * TCL_EVAL_GLOBAL and TCL_EVAL_NO_TRACEBACK + * are currently supported. */ { Interp *iPtr = (Interp *)interp; Trace *tracePtr; @@ -3158,7 +3158,7 @@ Tcl_EvalObjv(interp, objc, objv, flags) } } - if (code == TCL_ERROR) { + if ((code == TCL_ERROR) && !(flags & TCL_EVAL_NO_TRACEBACK)) { /* * If there was an error, a command string will be needed for the diff --git a/generic/tclInterp.c b/generic/tclInterp.c index c522607..65c41d9 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -9,7 +9,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.12 2002/03/07 20:17:22 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.13 2002/07/29 00:25:49 msofer Exp $ */ #include "tclInt.h" @@ -35,12 +35,6 @@ typedef struct Alias { Tcl_Obj *namePtr; /* Name of alias command in slave interp. */ Tcl_Interp *targetInterp; /* Interp in which target command will be * invoked. */ - Tcl_Obj *prefixPtr; /* Tcl list making up the prefix of the - * target command to be invoked in the target - * interpreter. Additional arguments - * specified when calling the alias in the - * slave interp will be appended to the prefix - * before the command is invoked. */ Tcl_Command slaveCmd; /* Source command in slave interpreter, * bound to command that invokes the target * command in the target interpreter. */ @@ -56,6 +50,16 @@ typedef struct Alias { * redirecting to it. Random access to this * hash table is never required - we are using * a hash table only for convenience. */ + unsigned int objc; /* Count of Tcl_Obj in the prefix of the + * target command to be invoked in the + * target interpreter. Additional arguments + * specified when calling the alias in the + * slave interp will be appended to the prefix + * before the command is invoked. */ + Tcl_Obj *objPtr; /* The first actual prefix object - the target + * command name; this has to be at the end of the + * structure, which will be extended to accomodate + * the remaining objects in the prefix. */ } Alias; /* @@ -945,7 +949,8 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv); + objc = aliasPtr->objc; + objv = &aliasPtr->objPtr; if (targetInterpPtr != NULL) { *targetInterpPtr = aliasPtr->targetInterp; @@ -1005,7 +1010,8 @@ Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv); + objc = aliasPtr->objc; + objv = &aliasPtr->objPtr; if (targetInterpPtr != (Tcl_Interp **) NULL) { *targetInterpPtr = aliasPtr->targetInterp; @@ -1075,17 +1081,16 @@ TclPreventAliasLoop(interp, cmdInterp, cmd) aliasPtr = (Alias *) cmdPtr->objClientData; nextAliasPtr = aliasPtr; while (1) { - int objc; - Tcl_Obj **objv; + Tcl_Obj *cmdNamePtr; /* * If the target of the next alias in the chain is the same as * the source alias, we have a loop. */ - Tcl_ListObjGetElements(NULL, nextAliasPtr->prefixPtr, &objc, &objv); + cmdNamePtr = nextAliasPtr->objPtr; aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, - Tcl_GetString(objv[0]), + Tcl_GetString(cmdNamePtr), Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), /*flags*/ 0); if (aliasCmd == (Tcl_Command) NULL) { @@ -1151,14 +1156,24 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, Target *targetPtr; Slave *slavePtr; Master *masterPtr; + int i; + Tcl_Obj **prefv; - aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias)); + aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) + + objc * sizeof(Tcl_Obj *))); aliasPtr->namePtr = namePtr; Tcl_IncrRefCount(aliasPtr->namePtr); aliasPtr->targetInterp = masterInterp; - aliasPtr->prefixPtr = Tcl_NewListObj(1, &targetNamePtr); - Tcl_ListObjReplace(NULL, aliasPtr->prefixPtr, 1, 0, objc, objv); - Tcl_IncrRefCount(aliasPtr->prefixPtr); + + aliasPtr->objc = objc + 1; + prefv = &aliasPtr->objPtr; + + *prefv = targetNamePtr; + Tcl_IncrRefCount(targetNamePtr); + for (i = 0; i < objc; i++) { + *(++prefv) = objv[i]; + Tcl_IncrRefCount(objv[i]); + } aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr, @@ -1175,7 +1190,9 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, Command *cmdPtr; Tcl_DecrRefCount(aliasPtr->namePtr); - Tcl_DecrRefCount(aliasPtr->prefixPtr); + for (i = 0; i < objc; i++) { + Tcl_DecrRefCount(objv[i]); + } cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; @@ -1264,7 +1281,7 @@ static int AliasDelete(interp, slaveInterp, namePtr) Tcl_Interp *interp; /* Interpreter for result & errors. */ Tcl_Interp *slaveInterp; /* Interpreter containing alias. */ - Tcl_Obj *namePtr; /* Name of alias to describe. */ + Tcl_Obj *namePtr; /* Name of alias to delete. */ { Slave *slavePtr; Alias *aliasPtr; @@ -1316,6 +1333,7 @@ AliasDescribe(interp, slaveInterp, namePtr) Slave *slavePtr; Tcl_HashEntry *hPtr; Alias *aliasPtr; + Tcl_Obj *prefixPtr; /* * If the alias has been renamed in the slave, the master can still use @@ -1329,7 +1347,8 @@ AliasDescribe(interp, slaveInterp, namePtr) return TCL_OK; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - Tcl_SetObjResult(interp, aliasPtr->prefixPtr); + prefixPtr = Tcl_NewListObj((int) aliasPtr->objc, &aliasPtr->objPtr); + Tcl_SetObjResult(interp, prefixPtr); return TCL_OK; } @@ -1400,84 +1419,51 @@ AliasObjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument vector. */ { +#define ALIAS_CMDV_PREALLOC 10 Tcl_Interp *targetInterp; Alias *aliasPtr; int result, prefc, cmdc; - Tcl_Obj *cmdPtr; Tcl_Obj **prefv, **cmdv; - + Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; aliasPtr = (Alias *) clientData; targetInterp = aliasPtr->targetInterp; - Tcl_Preserve((ClientData) targetInterp); - - ((Interp *) targetInterp)->numLevels++; - - Tcl_ResetResult(targetInterp); - Tcl_AllowExceptions(targetInterp); - - /* - * Check depth of nested calls with AliasObjCmd: if this gets too large, - * it's probably because of an infinite loop somewhere. - */ - - if (((Interp *) targetInterp)->numLevels > - ((Interp *) targetInterp)->maxNestingDepth) { - Tcl_AppendToObj(Tcl_GetObjResult(targetInterp), - "too many nested calls to AliasObjCmd (infinite loop using alias?)", -1); - result = TCL_ERROR; - goto done; - } - /* * Append the arguments to the command prefix and invoke the command * in the target interp's global namespace. */ - Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &prefc, &prefv); - cmdPtr = Tcl_NewListObj(prefc, prefv); - Tcl_ListObjReplace(NULL, cmdPtr, prefc, 0, objc - 1, objv + 1); - Tcl_ListObjGetElements(NULL, cmdPtr, &cmdc, &cmdv); - result = TclObjInvoke(targetInterp, cmdc, cmdv, - TCL_INVOKE_NO_TRACEBACK); - Tcl_DecrRefCount(cmdPtr); + prefc = aliasPtr->objc; + prefv = &aliasPtr->objPtr; + cmdc = prefc + objc - 1; + if (cmdc <= ALIAS_CMDV_PREALLOC) { + cmdv = cmdArr; + } else { + cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *))); + } - /* - * Check if we are at the bottom of the stack for the target interpreter. - * If so, check for special return codes. - */ - - if (((Interp *) targetInterp)->numLevels == 0) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo((Interp *) targetInterp); - } - if ((result != TCL_OK) && (result != TCL_ERROR)) { - Tcl_ResetResult(targetInterp); - if (result == TCL_BREAK) { - Tcl_SetObjResult(targetInterp, - Tcl_NewStringObj("invoked \"break\" outside of a loop", - -1)); - } else if (result == TCL_CONTINUE) { - Tcl_SetObjResult(targetInterp, - Tcl_NewStringObj( - "invoked \"continue\" outside of a loop", - -1)); - } else { - char buf[32 + TCL_INTEGER_SPACE]; - - sprintf(buf, "command returned bad code: %d", result); - Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1)); - } - result = TCL_ERROR; - } + prefv = &aliasPtr->objPtr; + memcpy((VOID *) cmdv, (VOID *) prefv, + (size_t) (prefc * sizeof(Tcl_Obj *))); + memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), + (size_t) ((objc-1) * sizeof(Tcl_Obj *))); + + Tcl_ResetResult(targetInterp); + + if (targetInterp != interp) { + Tcl_Preserve((ClientData) targetInterp); + result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_NO_TRACEBACK); + TclTransferResult(targetInterp, result, interp); + Tcl_Release((ClientData) targetInterp); + } else { + result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_NO_TRACEBACK); } - done: - ((Interp *) targetInterp)->numLevels--; - - TclTransferResult(targetInterp, result, interp); - Tcl_Release((ClientData) targetInterp); + if (cmdv != cmdArr) { + ckfree((char *) cmdv); + } return result; +#undef ALIAS_CMDV_PREALLOC } /* @@ -1504,11 +1490,16 @@ AliasObjCmdDeleteProc(clientData) { Alias *aliasPtr; Target *targetPtr; + int i; + Tcl_Obj **objv; aliasPtr = (Alias *) clientData; Tcl_DecrRefCount(aliasPtr->namePtr); - Tcl_DecrRefCount(aliasPtr->prefixPtr); + objv = &aliasPtr->objPtr; + for (i = 0; i < aliasPtr->objc; i++) { + Tcl_DecrRefCount(objv[i]); + } Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr); targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr); diff --git a/tests/interp.test b/tests/interp.test index f82151e..d5699cd 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.15 2002/07/01 07:52:03 dgp Exp $ +# RCS: @(#) $Id: interp.test,v 1.16 2002/07/29 00:25:49 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -2433,7 +2433,7 @@ test interp-29.3.1 {recursion limit} { }] interp delete $i set r -} {1 {too many nested calls to Tcl_Eval (infinite loop?)} 48} +} {1 {too many nested evaluations (infinite loop?)} 48} test interp-29.3.2 {recursion limit} { set i [interp create] @@ -2445,7 +2445,7 @@ test interp-29.3.2 {recursion limit} { }] interp delete $i set r -} {1 {too many nested calls to Tcl_Eval (infinite loop?)} 48} +} {1 {too many nested evaluations (infinite loop?)} 48} test interp-29.3.3 {recursion limit} { set i [interp create] @@ -2457,7 +2457,7 @@ test interp-29.3.3 {recursion limit} { }] interp delete $i set r -} {1 {too many nested calls to Tcl_Eval (infinite loop?)} 48} +} {1 {too many nested evaluations (infinite loop?)} 48} test interp-29.3.4 {recursion limit error reporting} { interp create slave @@ -2542,7 +2542,7 @@ test interp-29.3.7 {recursion limit error reporting} { set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 -} {1 {too many nested calls to Tcl_Eval (infinite loop?)}} +} {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.8 {recursion limit error reporting} { interp create slave @@ -2564,7 +2564,7 @@ test interp-29.3.8 {recursion limit error reporting} { set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 -} {1 {too many nested calls to Tcl_Eval (infinite loop?)}} +} {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.9 {recursion limit error reporting} { interp create slave @@ -2608,7 +2608,7 @@ test interp-29.3.10 {recursion limit error reporting} { set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 -} {1 {too many nested calls to Tcl_Eval (infinite loop?)}} +} {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.11 {recursion limit error reporting} { interp create slave @@ -2630,7 +2630,7 @@ test interp-29.3.11 {recursion limit error reporting} { set r2 [slave eval { set msg }] interp delete slave list $r1 $r2 -} {1 {too many nested calls to Tcl_Eval (infinite loop?)}} +} {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.12 {recursion limit error reporting} { interp create slave diff --git a/tests/stack.test b/tests/stack.test index 8d07bfb..828352b 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: stack.test,v 1.14 2002/06/22 04:19:47 dgp Exp $ +# RCS: @(#) $Id: stack.test,v 1.15 2002/07/29 00:25:49 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -43,7 +43,7 @@ test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} { catch {recurse} rv rename recurse {} set rv -} {too many nested calls to Tcl_Eval (infinite loop?)} +} {too many nested evaluations (infinite loop?)} test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} { # do this in a slave to not mess with parent @@ -53,7 +53,7 @@ test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} { set msg [$slave eval { catch {foo} msg ; set msg }] interp delete $slave set msg -} {too many nested calls to AliasObjCmd (infinite loop using alias?)} +} {too many nested evaluations (infinite loop?)} # cleanup ::tcltest::cleanupTests diff --git a/tests/trace.test b/tests/trace.test index 2229b69..10c70c9 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: trace.test,v 1.20 2002/07/18 13:37:46 msofer Exp $ +# RCS: @(#) $Id: trace.test,v 1.21 2002/07/29 00:25:50 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1805,6 +1805,32 @@ test trace-25.11 {delete command during enter and enterstep traces} { list $err $info [trace info execution foo] } {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} +test trace-26.1 {trace targetCmd when invoked through an alias} { + proc foo {args} { + set b $args + } + set info {} + trace add execution foo enter [list traceExecute foo] + interp alias {} bar {} foo 1 + bar 2 + trace remove execution foo enter [list traceExecute foo] + set info +} {{foo {foo 1 2} enter}} +test trace-26.2 {trace targetCmd when invoked through an alias} { + proc foo {args} { + set b $args + } + set info {} + trace add execution foo enter [list traceExecute foo] + interp create child + interp alias child bar {} foo 1 + child eval bar 2 + interp delete child + trace remove execution foo enter [list traceExecute foo] + set info +} {{foo {foo 1 2} enter}} + + # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} @@ -1814,3 +1840,4 @@ catch {rename bar {}} # cleanup ::tcltest::cleanupTests return + |