summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2011-03-09 14:06:53 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2011-03-09 14:06:53 (GMT)
commit1111254200cc2b8bc8aa2d899f43d56884f1f1cb (patch)
tree321682fffd0f114d52e16ad5231ed933e40ad10e
parent47412dd55bfb480602e28ca7d73b0aef74b622cb (diff)
downloadtcl-1111254200cc2b8bc8aa2d899f43d56884f1f1cb.zip
tcl-1111254200cc2b8bc8aa2d899f43d56884f1f1cb.tar.gz
tcl-1111254200cc2b8bc8aa2d899f43d56884f1f1cb.tar.bz2
Turn namespace into an ensemble. Not yet on trunk because of some mysterious failures that need resolving...
-rw-r--r--generic/tclBasic.c17
-rw-r--r--generic/tclCompCmds.c23
-rw-r--r--generic/tclEnsemble.c36
-rw-r--r--generic/tclInt.h7
-rw-r--r--generic/tclNamesp.c363
-rw-r--r--tests/namespace.test4
6 files changed, 198 insertions, 252 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 20cb1ad..9d5b006 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -237,7 +237,6 @@ static const CmdInfo builtInCmds[] = {
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, 1},
- {"namespace", Tcl_NamespaceObjCmd, TclCompileNamespaceCmd, TclNRNamespaceObjCmd, 1},
{"package", Tcl_PackageObjCmd, NULL, NULL, 1},
{"proc", Tcl_ProcObjCmd, NULL, NULL, 1},
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1},
@@ -780,10 +779,10 @@ Tcl_CreateInterp(void)
}
/*
- * Create the "array", "binary", "chan", "dict", "file", "info" and
- * "string" ensembles. Note that all these commands (and their subcommands
- * that are not present in the global namespace) are wholly safe *except*
- * for "file".
+ * Create the "array", "binary", "chan", "dict", "file", "info",
+ * "namespace" and "string" ensembles. Note that all these commands (and
+ * their subcommands that are not present in the global namespace) are
+ * wholly safe *except* for "file".
*/
TclInitArrayCmd(interp);
@@ -792,6 +791,7 @@ Tcl_CreateInterp(void)
TclInitDictCmd(interp);
TclInitFileCmd(interp);
TclInitInfoCmd(interp);
+ TclInitNamespaceCmd(interp);
TclInitStringCmd(interp);
TclInitPrefixCmd(interp);
@@ -825,10 +825,9 @@ Tcl_CreateInterp(void)
Tcl_RepresentationCmd, NULL, NULL);
/* Adding the bytecode assembler command */
- cmdPtr = (Command*)
- Tcl_NRCreateCommand(interp, "::tcl::unsupported::assemble",
- Tcl_AssembleObjCmd, TclNRAssembleObjCmd,
- NULL, NULL);
+ cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
+ "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
+ TclNRAssembleObjCmd, NULL, NULL);
cmdPtr->compileProc = &TclCompileAssembleCmd;
Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL,
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index c4d88a0..83e99aa 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3211,7 +3211,8 @@ TclCompileLsetCmd(
* TclCompileNamespaceCmd --
*
* Procedure called to compile the "namespace" command; currently, only
- * the subcommand "namespace upvar" is compiled to bytecodes.
+ * the subcommand "namespace upvar" is compiled to bytecodes, and then
+ * only inside a procedure(-like) context.
*
* Results:
* Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
@@ -3225,7 +3226,7 @@ TclCompileLsetCmd(
*/
int
-TclCompileNamespaceCmd(
+TclCompileNamespaceUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
@@ -3242,21 +3243,11 @@ TclCompileNamespaceCmd(
}
/*
- * Only compile [namespace upvar ...]: needs an odd number of args, >=5
+ * Only compile [namespace upvar ...]: needs an even number of args, >=4
*/
numWords = parsePtr->numWords;
- if (!(numWords%2) || (numWords < 5)) {
- return TCL_ERROR;
- }
-
- /*
- * Check if the second argument is "upvar"
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if ((tokenPtr->size != 5) /* 5 == strlen("upvar") */
- || strncmp(tokenPtr->start, "upvar", 5)) {
+ if ((numWords % 2) || (numWords < 4)) {
return TCL_ERROR;
}
@@ -3264,7 +3255,7 @@ TclCompileNamespaceCmd(
* Push the namespace
*/
- tokenPtr = TokenAfter(tokenPtr);
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
/*
@@ -3274,7 +3265,7 @@ TclCompileNamespaceCmd(
*/
localTokenPtr = tokenPtr;
- for (i=4; i<=numWords; i+=2) {
+ for (i=3; i<=numWords; i+=2) {
otherTokenPtr = TokenAfter(localTokenPtr);
localTokenPtr = TokenAfter(otherTokenPtr);
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index bc9ff16..bbc1e55 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -123,11 +123,11 @@ TclNamespaceEnsembleCmd(
return TCL_ERROR;
}
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?");
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[2], ensembleSubcommands,
+ if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands,
"subcommand", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
@@ -149,12 +149,12 @@ TclNamespaceEnsembleCmd(
* Check that we've got option-value pairs... [Bug 1558654]
*/
- if ((objc & 1) == 0) {
- Tcl_WrongNumArgs(interp, 3, objv, "?option value ...?");
+ if (objc & 1) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?");
return TCL_ERROR;
}
- objv += 3;
- objc -= 3;
+ objv += 2;
+ objc -= 2;
/*
* Work out what name to use for the command to create. If supplied,
@@ -322,29 +322,29 @@ TclNamespaceEnsembleCmd(
}
case ENS_EXISTS:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 3, objv, "cmdname");
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "cmdname");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
- Tcl_FindEnsemble(interp, objv[3], 0) != NULL));
+ Tcl_FindEnsemble(interp, objv[2], 0) != NULL));
return TCL_OK;
case ENS_CONFIG:
- if (objc < 4 || (objc != 5 && objc & 1)) {
- Tcl_WrongNumArgs(interp, 3, objv,
+ if (objc < 3 || (objc != 4 && !(objc & 1))) {
+ Tcl_WrongNumArgs(interp, 2, objv,
"cmdname ?-option value ...? ?arg ...?");
return TCL_ERROR;
}
- token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG);
+ token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG);
if (token == NULL) {
return TCL_ERROR;
}
- if (objc == 5) {
+ if (objc == 4) {
Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */
- if (Tcl_GetIndexFromObj(interp, objv[4], ensembleConfigOptions,
+ if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
@@ -388,7 +388,7 @@ TclNamespaceEnsembleCmd(
}
break;
}
- } else if (objc == 4) {
+ } else if (objc == 3) {
/*
* Produce list of all information.
*/
@@ -457,8 +457,8 @@ TclNamespaceEnsembleCmd(
Tcl_GetEnsembleFlags(NULL, token, &flags);
permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;
- objv += 4;
- objc -= 4;
+ objv += 3;
+ objc -= 3;
/*
* Parse the option list, applying type checks as we go. Note that
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 180e0e8..42e2212 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2750,7 +2750,6 @@ MODULE_SCOPE char tclEmptyString;
*----------------------------------------------------------------
*/
-MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
@@ -3327,9 +3326,7 @@ MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-MODULE_SCOPE int Tcl_NamespaceObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp);
MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3515,7 +3512,7 @@ MODULE_SCOPE int TclCompileLlengthCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileLsetCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
-MODULE_SCOPE int TclCompileNamespaceCmd(Tcl_Interp *interp,
+MODULE_SCOPE int TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileNoOp(Tcl_Interp *interp,
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index a777d27..69411c2 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -103,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,
@@ -114,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,
@@ -127,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);
@@ -150,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},
+ {"code", NamespaceCodeCmd},
+ {"current", NamespaceCurrentCmd},
+ {"delete", NamespaceDeleteCmd},
+ {"ensemble", TclNamespaceEnsembleCmd},
+ {"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd},
+ {"exists", NamespaceExistsCmd},
+ {"export", NamespaceExportCmd},
+ {"forget", NamespaceForgetCmd},
+ {"import", NamespaceImportCmd},
+ {"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd},
+ {"origin", NamespaceOriginCmd},
+ {"parent", NamespaceParentCmd},
+ {"path", NamespacePathCmd},
+ {"qualifiers", NamespaceQualifiersCmd},
+ {"tail", NamespaceTailCmd},
+ {"unknown", NamespaceUnknownCmd},
+ {"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd},
+ {"which", NamespaceWhichCmd},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+};
/*
*----------------------------------------------------------------------
@@ -2742,7 +2773,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)));
@@ -2790,132 +2821,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);
}
/*
@@ -2959,15 +2883,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;
}
@@ -2976,8 +2900,8 @@ 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;
@@ -3080,8 +3004,8 @@ NamespaceCodeCmd(
register const char *arg, *p;
int length;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "arg");
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "arg");
return TCL_ERROR;
}
@@ -3089,7 +3013,7 @@ NamespaceCodeCmd(
* If "arg" is already a scoped value, then return it directly.
*/
- arg = TclGetStringFromObj(objv[2], &length);
+ arg = TclGetStringFromObj(objv[1], &length);
while (*arg == ':') {
arg++;
length--;
@@ -3099,7 +3023,7 @@ NamespaceCodeCmd(
/* empty body: skip over whitespace */
}
if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==0) {
- Tcl_SetObjResult(interp, objv[2]);
+ Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
}
@@ -3126,7 +3050,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;
@@ -3162,8 +3086,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;
}
@@ -3227,8 +3151,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;
}
@@ -3238,7 +3162,7 @@ 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)
@@ -3256,7 +3180,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) {
@@ -3295,6 +3219,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. */
@@ -3308,8 +3243,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;
}
@@ -3318,14 +3253,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) {
@@ -3346,15 +3281,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);
@@ -3365,7 +3306,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;
}
@@ -3438,13 +3379,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;
}
@@ -3496,8 +3437,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;
}
@@ -3505,7 +3446,7 @@ NamespaceExportCmd(
* Process the optional "-clear" argument.
*/
- firstArg = 2;
+ firstArg = 1;
if (firstArg < objc) {
string = TclGetString(objv[firstArg]);
if (strcmp(string, "-clear") == 0) {
@@ -3519,9 +3460,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 {
/*
@@ -3595,12 +3536,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) {
@@ -3662,8 +3603,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;
}
@@ -3671,7 +3612,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)) {
@@ -3680,7 +3621,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.
*/
@@ -3756,6 +3697,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. */
@@ -3763,11 +3715,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;
}
@@ -3775,7 +3728,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;
}
@@ -3791,8 +3744,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
@@ -3801,21 +3760,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. */
@@ -3865,17 +3824,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);
+ TclGetString(objv[1]), "\"", NULL);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
- TclGetString(objv[2]), NULL);
+ TclGetString(objv[1]), NULL);
return TCL_ERROR;
}
origCommand = TclGetOriginalCommand(command);
@@ -3925,14 +3884,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;
}
@@ -3986,8 +3945,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;
}
@@ -3995,7 +3954,7 @@ NamespacePathCmd(
* If no path is given, return the current path.
*/
- if (objc == 2) {
+ if (objc == 1) {
/*
* Not a very fast way to compute this, but easy to get right.
*/
@@ -4013,7 +3972,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) {
@@ -4210,8 +4169,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;
}
@@ -4220,7 +4179,7 @@ NamespaceQualifiersCmd(
* the last "::" qualifier.
*/
- name = TclGetString(objv[2]);
+ name = TclGetString(objv[1]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
@@ -4279,14 +4238,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.
*/
@@ -4297,9 +4256,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;
}
@@ -4464,8 +4423,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;
}
@@ -4474,7 +4433,7 @@ NamespaceTailCmd(
* qualifier.
*/
- name = TclGetString(objv[2]);
+ name = TclGetString(objv[1]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
@@ -4525,17 +4484,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) {
/*
@@ -4600,16 +4559,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!
diff --git a/tests/namespace.test b/tests/namespace.test
index cda26f8..643514a 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -890,7 +890,7 @@ test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} -body {
namespace wombat {}
-} -returnCodes error -match glob -result {bad option "wombat": must be *}
+} -returnCodes error -match glob -result {unknown or ambiguous subcommand "wombat": must be *}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
namespace ch :: test_ns_*
} {}
@@ -1002,7 +1002,7 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} {
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} -body {
namespace test_ns_1
-} -returnCodes error -match glob -result {bad option "test_ns_1": must be *}
+} -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123