summaryrefslogtreecommitdiffstats
path: root/generic/tclNamesp.c
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2016-06-16 14:48:35 (GMT)
committerdgp <dgp@users.sourceforge.net>2016-06-16 14:48:35 (GMT)
commitb700360ad9501defb0b1e2d86353ac8d0db8eef4 (patch)
tree8b3bcb3adb8bd2eb44bcf16bb091722274e03e9e /generic/tclNamesp.c
parentc755ef08151343eb145710489f8c999edbef15ff (diff)
parent296aebbd6ee092a25741684fa37ee31ef5a3e222 (diff)
downloadtcl-b700360ad9501defb0b1e2d86353ac8d0db8eef4.zip
tcl-b700360ad9501defb0b1e2d86353ac8d0db8eef4.tar.gz
tcl-b700360ad9501defb0b1e2d86353ac8d0db8eef4.tar.bz2
Merge up to the 8.6.0 release.
Diffstat (limited to 'generic/tclNamesp.c')
-rw-r--r--generic/tclNamesp.c777
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:
*/