diff options
| -rw-r--r-- | generic/tclBasic.c | 17 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 23 | ||||
| -rw-r--r-- | generic/tclEnsemble.c | 36 | ||||
| -rw-r--r-- | generic/tclInt.h | 7 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 363 | ||||
| -rw-r--r-- | tests/namespace.test | 4 |
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 1d84131..7f86c38 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; int length; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arg"); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arg"); return TCL_ERROR; } @@ -3093,10 +3017,10 @@ NamespaceCodeCmd( " "namespace" command. [Bug 3202171]. */ - arg = TclGetStringFromObj(objv[2], &length); + arg = TclGetStringFromObj(objv[1], &length); if (*arg==':' && length > 20 && strncmp(arg, "::namespace inscope ", 20) == 0) { - Tcl_SetObjResult(interp, objv[2]); + Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } @@ -3122,7 +3046,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; @@ -3158,8 +3082,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; } @@ -3223,8 +3147,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; } @@ -3234,7 +3158,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) @@ -3252,7 +3176,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) { @@ -3291,6 +3215,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. */ @@ -3304,8 +3239,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; } @@ -3314,14 +3249,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) { @@ -3342,15 +3277,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); @@ -3361,7 +3302,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; } @@ -3434,13 +3375,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; } @@ -3492,8 +3433,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; } @@ -3501,7 +3442,7 @@ NamespaceExportCmd( * Process the optional "-clear" argument. */ - firstArg = 2; + firstArg = 1; if (firstArg < objc) { string = TclGetString(objv[firstArg]); if (strcmp(string, "-clear") == 0) { @@ -3515,9 +3456,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 { /* @@ -3591,12 +3532,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) { @@ -3658,8 +3599,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; } @@ -3667,7 +3608,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)) { @@ -3676,7 +3617,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. */ @@ -3752,6 +3693,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. */ @@ -3759,11 +3711,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; } @@ -3771,7 +3724,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; } @@ -3787,8 +3740,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 @@ -3797,21 +3756,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. */ @@ -3861,17 +3820,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); @@ -3921,14 +3880,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; } @@ -3982,8 +3941,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; } @@ -3991,7 +3950,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. */ @@ -4009,7 +3968,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) { @@ -4206,8 +4165,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; } @@ -4216,7 +4175,7 @@ NamespaceQualifiersCmd( * the last "::" qualifier. */ - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); for (p = name; *p != '\0'; p++) { /* empty body */ } @@ -4275,14 +4234,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. */ @@ -4293,9 +4252,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; } @@ -4460,8 +4419,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; } @@ -4470,7 +4429,7 @@ NamespaceTailCmd( * qualifier. */ - name = TclGetString(objv[2]); + name = TclGetString(objv[1]); for (p = name; *p != '\0'; p++) { /* empty body */ } @@ -4521,17 +4480,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) { /* @@ -4596,16 +4555,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 fe087a5..9d7cb59 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -896,7 +896,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_* } {} @@ -1013,7 +1013,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 |