diff options
| -rw-r--r-- | ChangeLog | 35 | ||||
| -rw-r--r-- | generic/tclBasic.c | 117 |
2 files changed, 139 insertions, 13 deletions
@@ -1,3 +1,38 @@ +2003-04-15 Andreas Kupries <andreask@activestate.com> + + * generic/tclBasic.c (Tcl_CloneInterp): Added code to propagate + error messages generated when cloning fails from the clone to + the master, for perusal by the code which activated the cloning + process. This is especially important to track syntax errors in + procedures to clone down. The code was provided by Greg Thompson + <gst@cisco.com>. + +2003-04-04 Andreas Kupries <andreask@activestate.com> + + * generic/tclBasic.c (CloneNamespace): Fixed potential memory leak + due to a missing call of "Tcl_DStringFree". Reported by Greg + Thompson <gst@cisco.com>. + +2003-03-24 Andreas Kupries <andreask@activestate.com> + + * generic/tclBasic.c (CloneCommand): Moved code adding the clone + to its command table to the end of the command. This makes + cleanup in case of a failure easier, there is less to roll + back. Added code to release the command strcuture if cloning the + procedure structures fails. changed from void to int, returning + a TCL_ result code. + + (CloneNamespace): Changed from void to int, returning a TCL_ + result code. Now reacting to the result of CloneCommand (and + itself), aborts operation in case of a failure. + + (Tcl_CloneInterp): Now reacting to a failure reported by + 'CloneNamespace'. Frees the fixup information accumulated so far + (via new CloneFixupFree), then deletes the partially created + interpreter via the standard 'Tcl_DeleteInterp'. + + (CloneFixupFree): New function, freeing the fixup information. + 2002-12-05 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclCompile.c (TclCleanupByteCode): when using diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3d124b4..85f76d1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -12,7 +12,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.27.6.7 2002/11/26 22:15:58 andreas_kupries Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.27.6.8 2003/04/15 18:25:15 andreas_kupries Exp $ */ #include <assert.h> #include "tclInt.h" @@ -3914,7 +3914,7 @@ static void CloneMathFunctions _ANSI_ARGS_((Interp* iPtr, Interp* srcIPtr)); static void ListMathFunctions _ANSI_ARGS_ ((Interp* iPtr, CONST char* mark)); #endif -static void CloneNamespace _ANSI_ARGS_((Interp* interp, Namespace* ns, +static int CloneNamespace _ANSI_ARGS_((Interp* interp, Namespace* ns, Namespace* srcNs, IRFixup* fixup)); static void CloneVariable _ANSI_ARGS_ ((Interp* interp, Namespace* ns, @@ -3924,12 +3924,13 @@ static void CloneVariable _ANSI_ARGS_ ((Interp* interp, Namespace* ns, static Tcl_HashTable* CloneArrayVariable _ANSI_ARGS_ ((Interp* interp, Var* varSrcPtr)); -static void CloneCommand _ANSI_ARGS_ ((Interp* interp, Namespace* ns, +static int CloneCommand _ANSI_ARGS_ ((Interp* interp, Namespace* ns, Command* cmdSrcPtr, CONST char* cmdName, IRFixup* fixup)); static void CloneFixupImports _ANSI_ARGS_ ((IRFixup* fixup)); static void CloneFixupVars _ANSI_ARGS_ ((IRFixup* fixup)); +static void CloneFixupFree _ANSI_ARGS_ ((IRFixup* fixup)); #define GetHashKeyString(hPtr) Tcl_GetHashKey ((hPtr->tablePtr),(hPtr)) @@ -3942,6 +3943,7 @@ Tcl_CloneInterp(srcInterp) Interp *srcIPtr = (Interp*) srcInterp; Interp *iPtr; Tcl_Interp *interp; + int res; IRFixup fixup; #ifndef TCL_THREAD_LITERALS @@ -4067,7 +4069,23 @@ Tcl_CloneInterp(srcInterp) * sharing bytecode information between interpreters. */ - CloneNamespace (iPtr, iPtr->globalNsPtr, srcIPtr->globalNsPtr, &fixup); + res = CloneNamespace (iPtr, iPtr->globalNsPtr, srcIPtr->globalNsPtr, &fixup); + if (res != TCL_OK) { + /* + * Something went wrong when cloning the namespace + * structure. Free up the no longer needed fixup information + * and then kill the partially initialized interpreter. + */ + + /* Pass the clone failure result to the source interpreter */ + Tcl_AppendObjToObj(Tcl_GetObjResult(srcInterp), + Tcl_GetObjResult(interp)); + + CloneFixupFree (&fixup); + Tcl_DeleteInterp (interp); + return (Tcl_Interp*) NULL; + } + CloneFixupImports (&fixup); CloneFixupVars (&fixup); @@ -4188,7 +4206,7 @@ CloneMathFunctions (iPtr, srcIPtr) } -static void +static int CloneNamespace (interp, ns, srcNs, fixup) Interp* interp; Namespace* ns; @@ -4213,6 +4231,7 @@ CloneNamespace (interp, ns, srcNs, fixup) Tcl_HashSearch commands; Command* cmdSrcPtr; + int res; /* * Phase I. Clone variables and their contents. @@ -4241,9 +4260,16 @@ CloneNamespace (interp, ns, srcNs, fixup) cmdSrcPtr = (Command *) Tcl_GetHashValue (hPtr); - CloneCommand (interp, ns, cmdSrcPtr, - GetHashKeyString (hPtr), - fixup); + res = CloneCommand (interp, ns, cmdSrcPtr, + GetHashKeyString (hPtr), + fixup); + if (res != TCL_OK) { + /* + * Cloning of the command failed. Bail out immediately, + * there is no sense in trying to clone more. + */ + return res; + } } /* @@ -4269,8 +4295,18 @@ CloneNamespace (interp, ns, srcNs, fixup) Tcl_DStringValue (&childName), (ClientData) childSrcPtr->clientData, (Tcl_NamespaceDeleteProc *) childSrcPtr->deleteProc); - CloneNamespace (interp, childPtr, childSrcPtr, fixup); + Tcl_DStringFree (&childName); + res = CloneNamespace (interp, childPtr, childSrcPtr, fixup); + if (res != TCL_OK) { + /* + * Cloning of the namespace failed (most likely in some command). + * Bail out immediately, there is no sense in trying to clone more. + */ + return res; + } } + + return TCL_OK; } @@ -4409,7 +4445,7 @@ CloneArrayVariable (interp, varSrcPtr) } -static void +static int CloneCommand (interp, ns, cmdSrcPtr, cmdName, fixup) Interp* interp; Namespace* ns; @@ -4420,9 +4456,6 @@ CloneCommand (interp, ns, cmdSrcPtr, cmdName, fixup) int new; Command* cmdNew = (Command *) ckalloc (sizeof (Command)); - cmdNew->hPtr = Tcl_CreateHashEntry(&ns->cmdTable, cmdName, &new); - Tcl_SetHashValue (cmdNew->hPtr, cmdNew); - cmdNew->nsPtr = ns; cmdNew->cmdEpoch = cmdSrcPtr->cmdEpoch; cmdNew->compileProc = cmdSrcPtr->compileProc; @@ -4489,6 +4522,20 @@ CloneCommand (interp, ns, cmdSrcPtr, cmdName, fixup) Proc *procPtr = TclCloneProc (interp, ns, (Proc *) cmdSrcPtr->objClientData); + if (procPtr == (Proc*) NULL) { + /* + * Some failure occured when cloning the + * procedure. Rolling back to a consistent state (freeing + * allocated command structure). There is no need to + * modify the fixup structure, it will be deallocated when + * the error reaches the main clone function. And moving + * the code which adds the clone to the command hastable + * to the end means that here and now the hashtable is + * still consistent too. + */ + ckfree ((char*) cmdNew); + return TCL_ERROR; + } /*assert (strcmp (cmdName, "foo") != 0);*/ cmdNew->objClientData = procPtr; @@ -4502,6 +4549,9 @@ CloneCommand (interp, ns, cmdSrcPtr, cmdName, fixup) * during execution ... */ cmdNew->refCount = 1; + cmdNew->hPtr = Tcl_CreateHashEntry(&ns->cmdTable, cmdName, &new); + Tcl_SetHashValue (cmdNew->hPtr, cmdNew); + return TCL_OK; } @@ -4615,6 +4665,47 @@ CloneFixupVars (fixup) } } +static void +CloneFixupFree (fixup) + IRFixup* fixup; +{ + IRFixupImported* irfi; + IRFixupCmdAssoc* irfa; + + IRFixupVar* irfiv; + IRFixupVarAssoc* irfav; + + /* Free transient data */ + + for (irfi = fixup->imported; + irfi; + fixup->imported = irfi->nextPtr, + ckfree ((char*) irfi), + irfi = fixup->imported) + ; + for (irfa = fixup->exported; + irfa; + fixup->exported = irfa->nextPtr, + ckfree ((char*) irfa), + irfa = fixup->exported) + ; + + /* Free transient data */ + + for (irfiv = fixup->varImported; + irfiv; + fixup->varImported = irfiv->nextPtr, + ckfree ((char*) irfiv), + irfiv = fixup->varImported) + ; + for (irfav = fixup->varExported; + irfav; + fixup->varExported = irfav->nextPtr, + ckfree ((char*) irfav), + irfav = fixup->varExported) + ; +} + #if 0 static void ListMathFunctions (iPtr,mark) |