diff options
Diffstat (limited to 'generic/tclNamesp.c')
-rw-r--r-- | generic/tclNamesp.c | 777 |
1 files changed, 428 insertions, 349 deletions
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 6961fd5..02d517f 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -21,12 +21,10 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclNamesp.c,v 1.212 2010/08/30 14:02:10 msofer Exp $ */ #include "tclInt.h" -#include "tclCompile.h" /* just for NRCommand */ +#include "tclCompile.h" /* for TclLogCommandInfo visibility */ /* * Thread-local storage used to avoid having a global lock on data that is not @@ -105,6 +103,8 @@ static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int NRNamespaceEvalCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, @@ -116,6 +116,8 @@ static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceInscopeCmd(ClientData dummy, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); +static int NRNamespaceInscopeCmd(ClientData dummy, + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp, @@ -129,8 +131,7 @@ static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp, static int NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int NamespaceUnknownCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); + Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -152,6 +153,34 @@ static const Tcl_ObjType nsNameType = { NULL, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; + +/* + * Array of values describing how to implement each standard subcommand of the + * "namespace" command. + */ + +static const EnsembleImplMap defaultNamespaceMap[] = { + {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0}, + {"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0}, + {"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0}, + {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0}, + {"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0}, + {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0}, + {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0}, + {"export", NamespaceExportCmd, NULL, NULL, NULL, 0}, + {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0}, + {"import", NamespaceImportCmd, NULL, NULL, NULL, 0}, + {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0}, + {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0}, + {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0}, + {"path", NamespacePathCmd, NULL, NULL, NULL, 0}, + {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0}, + {"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0}, + {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0}, + {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0}, + {"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} +}; /* *---------------------------------------------------------------------- @@ -368,7 +397,7 @@ Tcl_PopCallFrame( if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); - ckfree((char *) framePtr->varTablePtr); + ckfree(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { @@ -394,7 +423,7 @@ Tcl_PopCallFrame( framePtr->nsPtr = NULL; if (framePtr->tailcallPtr) { - TclSpliceTailcall(interp, framePtr->tailcallPtr); + TclSpliceTailcall(interp, framePtr->tailcallPtr); } } @@ -658,9 +687,10 @@ Tcl_CreateNamespace( parentPtr = NULL; simpleName = ""; } else if (*name == '\0') { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't create namespace \"\": " - "only global namespace can have empty name", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace" + " \"\": only global namespace can have empty name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEGLOBAL", NULL); return NULL; } else { /* @@ -694,8 +724,10 @@ Tcl_CreateNamespace( Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL #endif ) { - Tcl_AppendResult(interp, "can't create namespace \"", name, - "\": already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create namespace \"%s\": already exists", name)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE", + "CREATEEXISTING", NULL); return NULL; } } @@ -705,9 +737,10 @@ Tcl_CreateNamespace( * of namespaces created. */ - nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); - nsPtr->name = ckalloc((unsigned) (strlen(simpleName)+1)); - strcpy(nsPtr->name, simpleName); + nsPtr = ckalloc(sizeof(Namespace)); + nameLen = strlen(simpleName) + 1; + nsPtr->name = ckalloc(nameLen); + memcpy(nsPtr->name, simpleName, nameLen); nsPtr->fullName = NULL; /* Set below. */ nsPtr->clientData = clientData; nsPtr->deleteProc = deleteProc; @@ -769,10 +802,9 @@ Tcl_CreateNamespace( if (ancestorPtr != globalNsPtr) { register Tcl_DString *tempPtr = namePtr; - Tcl_DStringAppend(buffPtr, "::", 2); + TclDStringAppendLiteral(buffPtr, "::"); Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1); - Tcl_DStringAppend(buffPtr, Tcl_DStringValue(namePtr), - Tcl_DStringLength(namePtr)); + TclDStringAppendDString(buffPtr, namePtr); /* * Clear the unwanted buffer or we end up appending to previous @@ -780,7 +812,7 @@ Tcl_CreateNamespace( * very wrong (and strange). */ - Tcl_DStringSetLength(namePtr, 0); + TclDStringClear(namePtr); /* * Now swap the buffer pointers so that we build in the other @@ -795,7 +827,7 @@ Tcl_CreateNamespace( name = Tcl_DStringValue(namePtr); nameLen = Tcl_DStringLength(namePtr); - nsPtr->fullName = ckalloc((unsigned) (nameLen+1)); + nsPtr->fullName = ckalloc(nameLen + 1); memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1); Tcl_DStringFree(&buffer1); @@ -881,13 +913,13 @@ Tcl_DeleteNamespace( for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL;) { - cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); - if (cmdPtr->nreProc == NRInterpCoroutine) { + cmdPtr = Tcl_GetHashValue(entryPtr); + if (cmdPtr->nreProc == TclNRInterpCoroutine) { Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, (Tcl_Command) cmdPtr); entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); } else { - entryPtr = entryPtr->nextPtr; + entryPtr = Tcl_NextHashEntry(&search); } } @@ -976,7 +1008,7 @@ Tcl_DeleteNamespace( #else if (nsPtr->childTablePtr != NULL) { Tcl_DeleteHashTable(nsPtr->childTablePtr); - ckfree((char *) nsPtr->childTablePtr); + ckfree(nsPtr->childTablePtr); } #endif Tcl_DeleteHashTable(&nsPtr->cmdTable); @@ -1140,7 +1172,7 @@ TclTeardownNamespace( for (i = 0; i < nsPtr->numExportPatterns; i++) { ckfree(nsPtr->exportArrayPtr[i]); } - ckfree((char *) nsPtr->exportArrayPtr); + ckfree(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; @@ -1194,8 +1226,7 @@ NamespaceFree( ckfree(nsPtr->name); ckfree(nsPtr->fullName); - - ckfree((char *) nsPtr); + ckfree(nsPtr); } /* @@ -1287,7 +1318,7 @@ Tcl_Export( for (i = 0; i < nsPtr->numExportPatterns; i++) { ckfree(nsPtr->exportArrayPtr[i]); } - ckfree((char *) nsPtr->exportArrayPtr); + ckfree(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; TclInvalidateNsCmdLookup(nsPtr); nsPtr->numExportPatterns = 0; @@ -1304,8 +1335,9 @@ Tcl_Export( &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { - Tcl_AppendResult(interp, "invalid export pattern \"", pattern, - "\": pattern can't specify a namespace", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern" + " \"%s\": pattern can't specify a namespace", pattern)); + Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL); return TCL_ERROR; } @@ -1334,8 +1366,7 @@ Tcl_Export( if (neededElems > nsPtr->maxExportPatterns) { nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; - nsPtr->exportArrayPtr = (char **) - ckrealloc((char *) nsPtr->exportArrayPtr, + nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr, sizeof(char *) * nsPtr->maxExportPatterns); } @@ -1344,7 +1375,7 @@ Tcl_Export( */ len = strlen(pattern); - patternCpy = ckalloc((unsigned) (len + 1)); + patternCpy = ckalloc(len + 1); memcpy(patternCpy, pattern, (unsigned) len + 1); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; @@ -1511,6 +1542,7 @@ Tcl_Import( if (strlen(pattern) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL); return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, @@ -1518,20 +1550,22 @@ Tcl_Import( &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (importNsPtr == NULL) { - Tcl_AppendResult(interp, "unknown namespace in import pattern \"", - pattern, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in import pattern \"%s\"", pattern)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } if (importNsPtr == nsPtr) { if (pattern == simplePattern) { - Tcl_AppendResult(interp, - "no namespace specified in import pattern \"", pattern, - "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no namespace specified in import pattern \"%s\"", + pattern)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL); } else { - Tcl_AppendResult(interp, "import pattern \"", pattern, - "\" tries to import from namespace \"", - importNsPtr->name, "\" into itself", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" tries to import from namespace" + " \"%s\" into itself", pattern, importNsPtr->name)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL); } return TCL_ERROR; } @@ -1631,7 +1665,7 @@ DoImport( Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, nsPtr->fullName, -1); if (nsPtr != ((Interp *) interp)->globalNsPtr) { - Tcl_DStringAppend(&ds, "::", 2); + TclDStringAppendLiteral(&ds, "::"); } Tcl_DStringAppend(&ds, cmdName, -1); @@ -1649,16 +1683,18 @@ DoImport( dataPtr = linkCmd->objClientData; linkCmd = dataPtr->realCmdPtr; if (overwrite == linkCmd) { - Tcl_AppendResult(interp, "import pattern \"", pattern, - "\" would create a loop containing command \"", - Tcl_DStringValue(&ds), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "import pattern \"%s\" would create a loop" + " containing command \"%s\"", + pattern, Tcl_DStringValue(&ds))); Tcl_DStringFree(&ds); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL); return TCL_ERROR; } } } - dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); + dataPtr = ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); @@ -1672,7 +1708,7 @@ DoImport( * and add it to the import ref list in the "real" command. */ - refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); + refPtr = ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; @@ -1690,8 +1726,9 @@ DoImport( return TCL_OK; } } - Tcl_AppendResult(interp, "can't import command \"", cmdName, - "\": already exists", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't import command \"%s\": already exists", cmdName)); + Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL); return TCL_ERROR; } return TCL_OK; @@ -1759,9 +1796,9 @@ Tcl_ForgetImport( &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); if (sourceNsPtr == NULL) { - Tcl_AppendResult(interp, - "unknown namespace in namespace forget pattern \"", - pattern, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace in namespace forget pattern \"%s\"", + pattern)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); return TCL_ERROR; } @@ -1969,8 +2006,8 @@ DeleteImportedCmd( } else { prevPtr->nextPtr = refPtr->nextPtr; } - ckfree((char *) refPtr); - ckfree((char *) dataPtr); + ckfree(refPtr); + ckfree(dataPtr); return; } prevPtr = refPtr; @@ -2203,7 +2240,7 @@ TclGetNamespaceForQualName( * qualName since it may be a string constant. */ - Tcl_DStringSetLength(&buffer, 0); + TclDStringClear(&buffer); Tcl_DStringAppend(&buffer, start, len); nsName = Tcl_DStringValue(&buffer); } @@ -2365,8 +2402,8 @@ Tcl_FindNamespace( } if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); } return NULL; @@ -2552,8 +2589,8 @@ Tcl_FindCommand( } if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown command \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); } return NULL; @@ -2743,7 +2780,7 @@ TclGetNamespaceFromObj( * Get the current namespace name. */ - NamespaceCurrentCmd(NULL, interp, 2, NULL); + NamespaceCurrentCmd(NULL, interp, 1, NULL); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "namespace \"%s\" not found in \"%s\"", name, Tcl_GetStringResult(interp))); @@ -2770,18 +2807,18 @@ GetNamespaceFromObj( * cross interps. */ - resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && (!refNsPtr || ((interp == refNsPtr->interp) && - (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))) { + (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; + resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; } @@ -2791,132 +2828,25 @@ GetNamespaceFromObj( /* *---------------------------------------------------------------------- * - * Tcl_NamespaceObjCmd -- + * TclInitNamespaceCmd -- * - * Invoked to implement the "namespace" command that creates, deletes, or - * manipulates Tcl namespaces. Handles the following syntax: - * - * namespace children ?name? ?pattern? - * namespace code arg - * namespace current - * namespace delete ?name name...? - * namespace ensemble subcommand ?arg...? - * namespace eval name arg ?arg...? - * namespace exists name - * namespace export ?-clear? ?pattern pattern...? - * namespace forget ?pattern pattern...? - * namespace import ?-force? ?pattern pattern...? - * namespace inscope name arg ?arg...? - * namespace origin name - * namespace parent ?name? - * namespace qualifiers string - * namespace tail string - * namespace which ?-command? ?-variable? name + * This function is called to create the "namespace" Tcl command. See the + * user documentation for details on what it does. * * Results: - * Returns TCL_OK if the command is successful. Returns TCL_ERROR if - * anything goes wrong. + * Handle for the namespace command, or NULL on failure. * * Side effects: - * Based on the subcommand name (e.g., "import"), this function - * dispatches to a corresponding function NamespaceXXXCmd defined - * statically in this file. This function's side effects depend on - * whatever that subcommand function does. If there is an error, this - * function returns an error message in the interpreter's result object. - * Otherwise it may return a result in the interpreter's result object. + * none * *---------------------------------------------------------------------- */ -int -Tcl_NamespaceObjCmd( - ClientData clientData, /* Arbitrary value passed to cmd. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRNamespaceObjCmd, clientData, objc, - objv); -} - -int -TclNRNamespaceObjCmd( - ClientData clientData, /* Arbitrary value passed to cmd. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +Tcl_Command +TclInitNamespaceCmd( + Tcl_Interp *interp) /* Current interpreter. */ { - static const char *const subCmds[] = { - "children", "code", "current", "delete", "ensemble", - "eval", "exists", "export", "forget", "import", - "inscope", "origin", "parent", "path", "qualifiers", - "tail", "unknown", "upvar", "which", NULL - }; - enum NSSubCmdIdx { - NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, - NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, - NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, - NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx - }; - int index; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); - return TCL_ERROR; - } - - /* - * Return an index reflecting the particular subcommand. - */ - - if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", /*flags*/ 0, - (int *) &index) != TCL_OK) { - return TCL_ERROR; - } - - switch (index) { - case NSChildrenIdx: - return NamespaceChildrenCmd(clientData, interp, objc, objv); - case NSCodeIdx: - return NamespaceCodeCmd(clientData, interp, objc, objv); - case NSCurrentIdx: - return NamespaceCurrentCmd(clientData, interp, objc, objv); - case NSDeleteIdx: - return NamespaceDeleteCmd(clientData, interp, objc, objv); - case NSEnsembleIdx: - return TclNamespaceEnsembleCmd(clientData, interp, objc, objv); - case NSEvalIdx: - return NamespaceEvalCmd(clientData, interp, objc, objv); - case NSExistsIdx: - return NamespaceExistsCmd(clientData, interp, objc, objv); - case NSExportIdx: - return NamespaceExportCmd(clientData, interp, objc, objv); - case NSForgetIdx: - return NamespaceForgetCmd(clientData, interp, objc, objv); - case NSImportIdx: - return NamespaceImportCmd(clientData, interp, objc, objv); - case NSInscopeIdx: - return NamespaceInscopeCmd(clientData, interp, objc, objv); - case NSOriginIdx: - return NamespaceOriginCmd(clientData, interp, objc, objv); - case NSParentIdx: - return NamespaceParentCmd(clientData, interp, objc, objv); - case NSPathIdx: - return NamespacePathCmd(clientData, interp, objc, objv); - case NSQualifiersIdx: - return NamespaceQualifiersCmd(clientData, interp, objc, objv); - case NSTailIdx: - return NamespaceTailCmd(clientData, interp, objc, objv); - case NSUpvarIdx: - return NamespaceUpvarCmd(clientData, interp, objc, objv); - case NSUnknownIdx: - return NamespaceUnknownCmd(clientData, interp, objc, objv); - case NSWhichIdx: - return NamespaceWhichCmd(clientData, interp, objc, objv); - default: - Tcl_Panic("unhandled namespace subcommand"); - } - return TCL_ERROR; + return TclMakeEnsemble(interp, "namespace", defaultNamespaceMap); } /* @@ -2960,15 +2890,15 @@ NamespaceChildrenCmd( * Get a pointer to the specified namespace, or the current namespace. */ - if (objc == 2) { + if (objc == 1) { nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - } else if ((objc == 3) || (objc == 4)) { - if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK){ + } else if ((objc == 2) || (objc == 3)) { + if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK){ return TCL_ERROR; } nsPtr = (Namespace *) namespacePtr; } else { - Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); + Tcl_WrongNumArgs(interp, 1, objv, "?name? ?pattern?"); return TCL_ERROR; } @@ -2977,15 +2907,15 @@ NamespaceChildrenCmd( */ Tcl_DStringInit(&buffer); - if (objc == 4) { - const char *name = TclGetString(objv[3]); + if (objc == 3) { + const char *name = TclGetString(objv[2]); if ((*name == ':') && (*(name+1) == ':')) { pattern = name; } else { Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); if (nsPtr != globalNsPtr) { - Tcl_DStringAppend(&buffer, "::", 2); + TclDStringAppendLiteral(&buffer, "::"); } Tcl_DStringAppend(&buffer, name, -1); pattern = Tcl_DStringValue(&buffer); @@ -3078,31 +3008,27 @@ NamespaceCodeCmd( { Namespace *currNsPtr; Tcl_Obj *listPtr, *objPtr; - register const char *arg, *p; + register const char *arg; int length; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arg"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arg"); return TCL_ERROR; } /* * If "arg" is already a scoped value, then return it directly. + * Take care to only check for scoping in precisely the style that + * [::namespace code] generates it. Anything more forgiving can have + * the effect of failing in namespaces that contain their own custom + " "namespace" command. [Bug 3202171]. */ - arg = TclGetStringFromObj(objv[2], &length); - while (*arg == ':') { - arg++; - length--; - } - if (*arg=='n' && length>17 && strncmp(arg, "namespace", 9)==0) { - for (p=arg+9 ; isspace(UCHAR(*p)) ; p++) { - /* empty body: skip over whitespace */ - } - if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==0) { - Tcl_SetObjResult(interp, objv[2]); - return TCL_OK; - } + arg = TclGetStringFromObj(objv[1], &length); + if (*arg==':' && length > 20 + && strncmp(arg, "::namespace inscope ", 20) == 0) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } /* @@ -3127,7 +3053,7 @@ NamespaceCodeCmd( } Tcl_ListObjAppendElement(interp, listPtr, objPtr); - Tcl_ListObjAppendElement(interp, listPtr, objv[2]); + Tcl_ListObjAppendElement(interp, listPtr, objv[1]); Tcl_SetObjResult(interp, listPtr); return TCL_OK; @@ -3163,8 +3089,8 @@ NamespaceCurrentCmd( { register Namespace *currNsPtr; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } @@ -3228,8 +3154,8 @@ NamespaceDeleteCmd( const char *name; register int i; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?name name...?"); return TCL_ERROR; } @@ -3239,14 +3165,14 @@ NamespaceDeleteCmd( * command line are valid, and report any errors. */ - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); if ((namespacePtr == NULL) || (((Namespace *) namespacePtr)->flags & NS_KILLED)) { - Tcl_AppendResult(interp, "unknown namespace \"", - TclGetString(objv[i]), - "\" in namespace delete command", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown namespace \"%s\" in namespace delete command", + TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", TclGetString(objv[i]), NULL); return TCL_ERROR; @@ -3257,7 +3183,7 @@ NamespaceDeleteCmd( * Okay, now delete each namespace. */ - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { name = TclGetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0); if (namespacePtr) { @@ -3296,6 +3222,17 @@ NamespaceDeleteCmd( static int NamespaceEvalCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc, + objv); +} + +static int +NRNamespaceEvalCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -3309,8 +3246,8 @@ NamespaceEvalCmd( Tcl_Obj *objPtr; int result; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?"); return TCL_ERROR; } @@ -3319,14 +3256,14 @@ NamespaceEvalCmd( * namespace object along the way. */ - result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); + result = GetNamespaceFromObj(interp, objv[1], &namespacePtr); /* * If the namespace wasn't found, try to create it. */ if (result == TCL_ERROR) { - const char *name = TclGetString(objv[2]); + const char *name = TclGetString(objv[1]); namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL); if (namespacePtr == NULL) { @@ -3347,15 +3284,21 @@ NamespaceEvalCmd( return TCL_ERROR; } - framePtr->objc = objc; - framePtr->objv = objv; + if (iPtr->ensembleRewrite.sourceObjs == NULL) { + framePtr->objc = objc; + framePtr->objv = objv; + } else { + framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + framePtr->objv = iPtr->ensembleRewrite.sourceObjs; + } - if (objc == 4) { + if (objc == 3) { /* * TIP #280: Make actual argument location available to eval'd script. */ - objPtr = objv[3]; + objPtr = objv[2]; invoker = iPtr->cmdFramePtr; word = 3; TclArgumentGet(interp, objPtr, &invoker, &word); @@ -3366,7 +3309,7 @@ NamespaceEvalCmd( * object when it decrements its refcount after eval'ing it. */ - objPtr = Tcl_ConcatObj(objc-3, objv+3); + objPtr = Tcl_ConcatObj(objc-2, objv+2); invoker = NULL; word = 0; } @@ -3439,13 +3382,13 @@ NamespaceExistsCmd( { Tcl_Namespace *namespacePtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - GetNamespaceFromObj(interp, objv[2], &namespacePtr) == TCL_OK)); + GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK)); return TCL_OK; } @@ -3497,8 +3440,8 @@ NamespaceExportCmd( int resetListFirst = 0; int firstArg, patternCt, i, result; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?"); return TCL_ERROR; } @@ -3506,7 +3449,7 @@ NamespaceExportCmd( * Process the optional "-clear" argument. */ - firstArg = 2; + firstArg = 1; if (firstArg < objc) { string = TclGetString(objv[firstArg]); if (strcmp(string, "-clear") == 0) { @@ -3520,9 +3463,9 @@ NamespaceExportCmd( * the namespace's current export pattern list. */ - patternCt = (objc - firstArg); + patternCt = objc - firstArg; if (patternCt == 0) { - if (firstArg > 2) { + if (firstArg > 1) { return TCL_OK; } else { /* @@ -3596,12 +3539,12 @@ NamespaceForgetCmd( const char *pattern; register int i, result; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?"); return TCL_ERROR; } - for (i = 2; i < objc; i++) { + for (i = 1; i < objc; i++) { pattern = TclGetString(objv[i]); result = Tcl_ForgetImport(interp, NULL, pattern); if (result != TCL_OK) { @@ -3663,8 +3606,8 @@ NamespaceImportCmd( register int i, result; int firstArg; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?"); return TCL_ERROR; } @@ -3672,7 +3615,7 @@ NamespaceImportCmd( * Skip over the optional "-force" as the first argument. */ - firstArg = 2; + firstArg = 1; if (firstArg < objc) { string = TclGetString(objv[firstArg]); if ((*string == '-') && (strcmp(string, "-force") == 0)) { @@ -3681,7 +3624,7 @@ NamespaceImportCmd( } } else { /* - * When objc == 2, command is just [namespace import]. Introspection + * When objc == 1, command is just [namespace import]. Introspection * form to return list of imported commands. */ @@ -3757,6 +3700,17 @@ NamespaceImportCmd( static int NamespaceInscopeCmd( + ClientData clientData, /* Arbitrary value passed to cmd. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc, + objv); +} + +static int +NRNamespaceInscopeCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -3764,11 +3718,12 @@ NamespaceInscopeCmd( { Tcl_Namespace *namespacePtr; CallFrame *framePtr, **framePtrPtr; + register Interp *iPtr = (Interp *) interp; int i, result; Tcl_Obj *cmdObjPtr; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?"); return TCL_ERROR; } @@ -3776,7 +3731,7 @@ NamespaceInscopeCmd( * Resolve the namespace reference. */ - if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { + if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK) { return TCL_ERROR; } @@ -3792,8 +3747,14 @@ NamespaceInscopeCmd( return result; } - framePtr->objc = objc; - framePtr->objv = objv; + if (iPtr->ensembleRewrite.sourceObjs == NULL) { + framePtr->objc = objc; + framePtr->objv = objv; + } else { + framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs + - iPtr->ensembleRewrite.numInsertedObjs; + framePtr->objv = iPtr->ensembleRewrite.sourceObjs; + } /* * Execute the command. If there is just one argument, just treat it as a @@ -3802,21 +3763,21 @@ NamespaceInscopeCmd( * of extra arguments to form the command to evaluate. */ - if (objc == 4) { - cmdObjPtr = objv[3]; + if (objc == 3) { + cmdObjPtr = objv[2]; } else { Tcl_Obj *concatObjv[2]; register Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); - for (i = 4; i < objc; i++) { + for (i = 3; i < objc; i++) { if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){ Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */ return TCL_ERROR; } } - concatObjv[0] = objv[3]; + concatObjv[0] = objv[2]; concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); Tcl_DecrRefCount(listPtr); /* We're done with the list object. */ @@ -3866,17 +3827,17 @@ NamespaceOriginCmd( Tcl_Command command, origCommand; Tcl_Obj *resultPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - command = Tcl_GetCommandFromObj(interp, objv[2]); + command = Tcl_GetCommandFromObj(interp, objv[1]); if (command == NULL) { - Tcl_AppendResult(interp, "invalid command name \"", - TclGetString(objv[2]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "invalid command name \"%s\"", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", - TclGetString(objv[2]), NULL); + TclGetString(objv[1]), NULL); return TCL_ERROR; } origCommand = TclGetOriginalCommand(command); @@ -3926,14 +3887,14 @@ NamespaceParentCmd( { Tcl_Namespace *nsPtr; - if (objc == 2) { + if (objc == 1) { nsPtr = TclGetCurrentNamespace(interp); - } else if (objc == 3) { - if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { + } else if (objc == 2) { + if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + Tcl_WrongNumArgs(interp, 1, objv, "?name?"); return TCL_ERROR; } @@ -3987,8 +3948,8 @@ NamespacePathCmd( Tcl_Obj **nsObjv; Tcl_Namespace **namespaceList = NULL; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?pathList?"); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pathList?"); return TCL_ERROR; } @@ -3996,17 +3957,16 @@ NamespacePathCmd( * If no path is given, return the current path. */ - if (objc == 2) { - /* - * Not a very fast way to compute this, but easy to get right. - */ + if (objc == 1) { + Tcl_Obj *resultObj = Tcl_NewObj(); for (i=0 ; i<nsPtr->commandPathLength ; i++) { if (nsPtr->commandPathArray[i].nsPtr != NULL) { - Tcl_AppendElement(interp, - nsPtr->commandPathArray[i].nsPtr->fullName); + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj( + nsPtr->commandPathArray[i].nsPtr->fullName, -1)); } } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -4014,7 +3974,7 @@ NamespacePathCmd( * There is a path given, so parse it into an array of namespace pointers. */ - if (TclListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) { goto badNamespace; } if (nsObjc != 0) { @@ -4070,7 +4030,7 @@ TclSetNsPath( Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */ { if (pathLength != 0) { - NamespacePathEntry *tmpPathArray = (NamespacePathEntry *) + NamespacePathEntry *tmpPathArray = ckalloc(sizeof(NamespacePathEntry) * pathLength); int i; @@ -4139,7 +4099,7 @@ UnlinkNsPath( } } } - ckfree((char *) nsPtr->commandPathArray); + ckfree(nsPtr->commandPathArray); } /* @@ -4211,8 +4171,8 @@ NamespaceQualifiersCmd( register const char *name, *p; int length; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } @@ -4221,7 +4181,7 @@ NamespaceQualifiersCmd( * the last "::" qualifier. */ - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); for (p = name; *p != '\0'; p++) { /* empty body */ } @@ -4280,14 +4240,14 @@ NamespaceUnknownCmd( Tcl_Obj *resultPtr; int rc; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?script?"); + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?script?"); return TCL_ERROR; } currNsPtr = TclGetCurrentNamespace(interp); - if (objc == 2) { + if (objc == 1) { /* * Introspection - return the current namespace handler. */ @@ -4298,9 +4258,9 @@ NamespaceUnknownCmd( } Tcl_SetObjResult(interp, resultPtr); } else { - rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[2]); + rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[1]); if (rc == TCL_OK) { - Tcl_SetObjResult(interp, objv[2]); + Tcl_SetObjResult(interp, objv[1]); } return rc; } @@ -4465,8 +4425,8 @@ NamespaceTailCmd( { register const char *name, *p; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } @@ -4475,7 +4435,7 @@ NamespaceTailCmd( * qualifier. */ - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); for (p = name; *p != '\0'; p++) { /* empty body */ } @@ -4526,17 +4486,17 @@ NamespaceUpvarCmd( Var *otherPtr, *arrayPtr; const char *myName; - if (objc < 3 || !(objc & 1)) { - Tcl_WrongNumArgs(interp, 2, objv, "ns ?otherVar myVar ...?"); + if (objc < 2 || (objc & 1)) { + Tcl_WrongNumArgs(interp, 1, objv, "ns ?otherVar myVar ...?"); return TCL_ERROR; } - if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { + if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) { return TCL_ERROR; } - objc -= 3; - objv += 3; + objc -= 2; + objv += 2; for (; objc>0 ; objc-=2, objv+=2) { /* @@ -4601,16 +4561,16 @@ NamespaceWhichCmd( int lookupType = 0; Tcl_Obj *resultPtr; - if (objc < 3 || objc > 4) { + if (objc < 2 || objc > 3) { badArgs: - Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name"); + Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name"); return TCL_ERROR; - } else if (objc == 4) { + } else if (objc == 3) { /* * Look for a flag controlling the lookup. */ - if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0, &lookupType) != TCL_OK) { /* * Preserve old style of error message! @@ -4685,7 +4645,7 @@ FreeNsNameInternalRep( */ TclNsDecrRefCount(resNamePtr->nsPtr); - ckfree((char *) resNamePtr); + ckfree(resNamePtr); } objPtr->typePtr = NULL; } @@ -4753,8 +4713,13 @@ SetNsNameFromAny( const char *dummy; Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; register ResolvedNsName *resNamePtr; - const char *name = TclGetString(objPtr); + const char *name; + + if (interp == NULL) { + return TCL_ERROR; + } + name = TclGetString(objPtr); TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); @@ -4772,13 +4737,12 @@ SetNsNameFromAny( if (objPtr->typePtr == &nsNameType) { TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; } return TCL_ERROR; } nsPtr->refCount++; - resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); + resNamePtr = ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; @@ -4840,7 +4804,7 @@ TclGetNamespaceChildTable( return &nPtr->childTable; #else if (nPtr->childTablePtr == NULL) { - nPtr->childTablePtr = (Tcl_HashTable*) ckalloc(sizeof(Tcl_HashTable)); + nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS); } return nPtr->childTablePtr; @@ -4850,31 +4814,37 @@ TclGetNamespaceChildTable( /* *---------------------------------------------------------------------- * - * Tcl_LogCommandInfo -- + * TclLogCommandInfo -- * * This function is invoked after an error occurs in an interpreter. It - * adds information to iPtr->errorInfo field to describe the command that - * was being executed when the error occurred. + * adds information to iPtr->errorInfo/errorStack fields to describe the + * command that was being executed when the error occurred. When pc and + * tosPtr are non-NULL, conveying a bytecode execution "inner context", + * and the offending instruction is suitable, that inner context is + * recorded in errorStack. * * Results: * None. * * Side effects: - * Information about the command is added to errorInfo and the line - * number stored internally in the interpreter is set. + * Information about the command is added to errorInfo/errorStack and the + * line number stored internally in the interpreter is set. * *---------------------------------------------------------------------- */ void -Tcl_LogCommandInfo( +TclLogCommandInfo( Tcl_Interp *interp, /* Interpreter in which to log information. */ const char *script, /* First character in script containing * command (must be <= command). */ const char *command, /* First character in command that generated * the error. */ - int length) /* Number of bytes in command (-1 means use + int length, /* Number of bytes in command (-1 means use * all bytes up to first null byte). */ + const unsigned char *pc, /* Current pc of bytecode execution context */ + Tcl_Obj **tosPtr) /* Current stack of bytecode execution + * context */ { register const char *p; Interp *iPtr = (Interp *) interp; @@ -4891,55 +4861,55 @@ Tcl_LogCommandInfo( } if (command != NULL) { - /* - * Compute the line number where the error occurred. - */ - - iPtr->errorLine = 1; - for (p = script; p != command; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - if (length < 0) { - length = strlen(command); - } - overflow = (length > limit); - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + if (length < 0) { + length = strlen(command); + } + overflow = (length > limit); + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) ? "while executing" : "invoked from within"), (overflow ? limit : length), command, (overflow ? "..." : ""))); - varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, + varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, NULL, 0, 0, &arrayPtr); - if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { - /* - * Should not happen. - */ - - return; - } else { - Tcl_HashEntry *hPtr + if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { + /* + * Should not happen. + */ + + return; + } else { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); - VarTrace *tracePtr = Tcl_GetHashValue(hPtr); + VarTrace *tracePtr = Tcl_GetHashValue(hPtr); - if (tracePtr->traceProc != EstablishErrorInfoTraces) { - /* - * The most recent trace set on ::errorInfo is not the one the - * core itself puts on last. This means some other code is + if (tracePtr->traceProc != EstablishErrorInfoTraces) { + /* + * The most recent trace set on ::errorInfo is not the one the + * core itself puts on last. This means some other code is * tracing the variable, and the additional trace(s) might be * write traces that expect the timing of writes to * ::errorInfo that existed Tcl releases before 8.5. To * satisfy that compatibility need, we write the current * -errorinfo value to the ::errorInfo variable. - */ + */ - Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, + Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); - } - } + } + } } /* @@ -4947,44 +4917,153 @@ Tcl_LogCommandInfo( */ if (Tcl_IsShared(iPtr->errorStack)) { - Tcl_Obj *newObj; - - newObj = Tcl_DuplicateObj(iPtr->errorStack); - Tcl_DecrRefCount(iPtr->errorStack); - Tcl_IncrRefCount(newObj); - iPtr->errorStack = newObj; + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; } if (iPtr->resetErrorStack) { int len; - iPtr->resetErrorStack = 0; + iPtr->resetErrorStack = 0; Tcl_ListObjLength(interp, iPtr->errorStack, &len); - /* reset while keeping the list intrep as much as possible */ - Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + if (pc != NULL) { + Tcl_Obj *innerContext; + + innerContext = TclGetInnerContext(interp, pc, tosPtr); + if (innerContext != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext); + } + } else if (command != NULL) { + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(command, length)); + } } if (!iPtr->framePtr->objc) { - /* special frame, nothing to report */ + /* + * Special frame, nothing to report. + */ } else if (iPtr->varFramePtr != iPtr->framePtr) { - /* uplevel case, [lappend errorstack UP $relativelevel] */ + /* + * uplevel case, [lappend errorstack UP $relativelevel] + */ - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj( iPtr->framePtr->level - iPtr->varFramePtr->level)); } else if (iPtr->framePtr != iPtr->rootFramePtr) { - /* normal case, [lappend errorstack CALL [info level 0]] */ - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); - Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( + /* + * normal case, [lappend errorstack CALL [info level 0]] + */ + + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj( iPtr->framePtr->objc, iPtr->framePtr->objv)); } } /* + *---------------------------------------------------------------------- + * + * TclErrorStackResetIf -- + * + * The TIP 348 reset/no-bc part of TLCI, for specific use by + * TclCompileSyntaxError. + * + * Results: + * None. + * + * Side effects: + * Reset errorstack if it needs be, and in that case remember the + * passed-in error message as inner context. + * + *---------------------------------------------------------------------- + */ + +void +TclErrorStackResetIf( + Tcl_Interp *interp, + const char *msg, + int length) +{ + Interp *iPtr = (Interp *) interp; + + if (Tcl_IsShared(iPtr->errorStack)) { + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; + } + if (iPtr->resetErrorStack) { + int len; + + iPtr->resetErrorStack = 0; + Tcl_ListObjLength(interp, iPtr->errorStack, &len); + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral); + Tcl_ListObjAppendElement(NULL, iPtr->errorStack, + Tcl_NewStringObj(msg, length)); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LogCommandInfo -- + * + * This function is invoked after an error occurs in an interpreter. It + * adds information to iPtr->errorInfo/errorStack fields to describe the + * command that was being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo/errorStack and the + * line number stored internally in the interpreter is set. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_LogCommandInfo( + Tcl_Interp *interp, /* Interpreter in which to log information. */ + const char *script, /* First character in script containing + * command (must be <= command). */ + const char *command, /* First character in command that generated + * the error. */ + int length) /* Number of bytes in command (-1 means use + * all bytes up to first null byte). */ +{ + TclLogCommandInfo(interp, script, command, length, NULL, NULL); +} + + +/* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * tab-width: 8 - * indent-tabs-mode: nil * End: */ |