diff options
| -rw-r--r-- | ChangeLog | 14 | ||||
| -rw-r--r-- | doc/Namespace.3 | 20 | ||||
| -rw-r--r-- | doc/namespace.n | 13 | ||||
| -rw-r--r-- | doc/unknown.n | 21 | ||||
| -rw-r--r-- | generic/tcl.decls | 15 | ||||
| -rw-r--r-- | generic/tclBasic.c | 69 | ||||
| -rw-r--r-- | generic/tclDecls.h | 25 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 185 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 4 | ||||
| -rw-r--r-- | tests/namespace.test | 92 |
11 files changed, 430 insertions, 33 deletions
@@ -1,5 +1,19 @@ 2006-02-01 Don Porter <dgp@users.sourceforge.net> + TIP#181 IMPLEMENTATION + + * doc/Namespace.3: New command [namespace unknown]. New public + * doc/namespace.n: C routines Tcl_(Get|Set)NamespaceUnknownHandler. + * doc/unknown.n: [Patch 958222]. + * generic/tcl.decls: + * generic/tclBasic.c: + * generic/tclInt.h: + * generic/tclNamesp.c: + * tests/namespace.test: + + * generic/tclDecls.h: make genstubs + * generic/tclStubInit.c: + TIP#250 IMPLEMENTATION * doc/namespace.n: New command [namespace upvar]. [Patch 1275435] diff --git a/doc/Namespace.3 b/doc/Namespace.3 index 5f61f2b..7bc77f4 100644 --- a/doc/Namespace.3 +++ b/doc/Namespace.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: Namespace.3,v 1.7 2004/10/07 15:15:38 dkf Exp $ +'\" RCS: @(#) $Id: Namespace.3,v 1.8 2006/02/01 18:27:43 dgp Exp $ '\" '\" Note that some of these functions do not seem to belong, but they '\" were all introduced with the same TIP (#139) @@ -13,7 +13,7 @@ .TH Tcl_Namespace 3 8.5 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_AppendExportList, Tcl_CreateNamespace, Tcl_DeleteNamespace, Tcl_Export, Tcl_FindCommand, Tcl_FindNamespace, Tcl_ForgetImport, Tcl_GetCurrentNamespace, Tcl_GetGloblaNamespace, Tcl_Import \- manipulate namespaces +Tcl_AppendExportList, Tcl_CreateNamespace, Tcl_DeleteNamespace, Tcl_Export, Tcl_FindCommand, Tcl_FindNamespace, Tcl_ForgetImport, Tcl_GetCurrentNamespace, Tcl_GetGloblaNamespace, Tcl_GetNamespaceUnknownHandler, Tcl_Import, Tcl_SetNamespaceUnknownHandler \- manipulate namespaces .SH SYNOPSIS .nf \fB#include <tcl.h>\fR @@ -46,6 +46,12 @@ Tcl_Namespace * .sp Tcl_Command \fBTcl_FindCommand\fR(\fIinterp, name, contextNsPtr, flags\fR) +.sp +Tcl_Obj * +\fBTcl_GetNamespaceUnknownHandler(\fIinterp, nsPtr\fR) +.sp +int +\fBTcl_SetNamespaceUnknownHandler(\fIinterp, nsPtr, handlerPtr\fR) .SH ARGUMENTS .AS Tcl_NamespaceDeleteProc allowOverwrite in/out .AP Tcl_Interp *interp in/out @@ -87,6 +93,9 @@ global namespace), \fBTCL_NAMESPACE_ONLY\fR (just for \fBTcl_FindCommand\fR; indicates that the search is always to be conducted relative to the context namespace), and \fBTCL_LEAVE_ERR_MSG\fR (indicates that an error message should be left in the interpreter if the search fails.) +.AP Tcl_Obj *handlerPtr in +A script fragment to be installed as the unknown command handler for the +namespace, or NULL to reset the handler to its default. .BE .SH DESCRIPTION @@ -143,6 +152,13 @@ namespace cannot be found, NULL is returned. \fBTcl_FindCommand\fR searches for a command named \fIname\fR within the context of the namespace \fIcontextNsPtr\fR. If the command cannot be found, NULL is returned. +.PP +\fBTcl_GetNamespaceUnknownHandler\fR returns the unknown command handler +for the namespace, or NULL if none is set. +.PP +\fBTcl_SetNamespaceUnknownHandler\fR sets the unknown command handler for +the namespace. If \fIhandlerPtr\fR is NULL, then the handler is reset to +its default. .SH "SEE ALSO" Tcl_CreateCommand, Tcl_ListObjAppendElements, Tcl_SetVar diff --git a/doc/namespace.n b/doc/namespace.n index f2327a4..150e7ee 100644 --- a/doc/namespace.n +++ b/doc/namespace.n @@ -7,7 +7,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: namespace.n,v 1.19 2006/02/01 17:48:10 dgp Exp $ +'\" RCS: @(#) $Id: namespace.n,v 1.20 2006/02/01 18:27:43 dgp Exp $ '\" .so man.macros .TH namespace n 8.5 Tcl "Tcl Built-In Commands" @@ -256,6 +256,17 @@ procedure to refer to variables in \fInamespace\fR. The command \fBupvar 0 $ns::a b\fR. \fBnamespace upvar\fR returns an empty string. .TP +\fBnamespace unknown\fR ?\fIscript\fR? +Sets or returns the unknown command handler for the current namespace. +The handler is invoked when a command called from within the namespace +cannot be found (in either the current namespace or the global namespace). +The \fIscript\fR argument, if given, should be a well +formed list representing a command name and optional arguments. When +the handler is invoked, the full invocation line will be appended to the +script and the result evaluated in the context of the namespace. The +default handler for all namespaces is \fB::unknown\fR. If no argument +is given, it returns the handler for the current namespace. +.TP \fBnamespace which\fR ?\-\fBcommand\fR? ?\-\fBvariable\fR? \fIname\fR Looks up \fIname\fR as either a command or variable and returns its fully-qualified name. diff --git a/doc/unknown.n b/doc/unknown.n index 95bb066..6ece5f3 100644 --- a/doc/unknown.n +++ b/doc/unknown.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: unknown.n,v 1.5 2004/05/30 14:13:52 dkf Exp $ +'\" RCS: @(#) $Id: unknown.n,v 1.6 2006/02/01 18:27:43 dgp Exp $ '\" .so man.macros .TH unknown n "" Tcl "Tcl Built-In Commands" @@ -23,15 +23,18 @@ This command is invoked by the Tcl interpreter whenever a script tries to invoke a command that doesn't exist. The default implementation of \fBunknown\fR is a library procedure defined when Tcl initializes an interpreter. You can override the default \fBunknown\fR to change its -functionality. Note that there is no default implementation of -\fBunknown\fR in a safe interpreter. +functionality, or you can register a new handler for individual namespaces +using the \fBnamespace unknown\fR command. Note that there is no default +implementation of \fBunknown\fR in a safe interpreter. .PP If the Tcl interpreter encounters a command name for which there -is not a defined command, then Tcl checks for the existence of -a command named \fBunknown\fR. -If there is no such command, then the interpreter returns an -error. -If the \fBunknown\fR command exists, then it is invoked with +is not a defined command (in either the current namespace, or the +global namespace), then Tcl checks for the existence of +an unknown handler for the current namespace. By default, this +handler is a command named \fB::unknown\fR. If there is no such +command, then the interpreter returns an error. +If the \fBunknown\fR command exists (or a new handler has been +registered for the current namespace), then it is invoked with arguments consisting of the fully-substituted name and arguments for the original non-existent command. The \fBunknown\fR command typically does things like searching @@ -87,7 +90,7 @@ proc \fBunknown\fR args { .CE .SH "SEE ALSO" -info(n), proc(n), interp(n), library(n) +info(n), proc(n), interp(n), library(n), namespace(n) .SH KEYWORDS error, non-existent command diff --git a/generic/tcl.decls b/generic/tcl.decls index 410538d..6fe33f1 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.118 2005/12/27 20:14:08 kennykb Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.119 2006/02/01 18:27:43 dgp Exp $ library tcl @@ -2037,7 +2037,17 @@ declare 566 generic { int Tcl_InitBignumFromDouble(Tcl_Interp* interp, double initval, mp_int *toInit) } - + +# TIP 181 +declare 567 generic { + Tcl_Obj *Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp, + Tcl_Namespace *nsPtr) +} +declare 568 generic { + int Tcl_SetNamespaceUnknownHandler( + Tcl_Interp *interp, Tcl_Namespace *nsPtr, + Tcl_Obj *handlerPtr) +} ############################################################################## @@ -2078,6 +2088,7 @@ declare 1 macosx { char *libraryPath) } + ############################################################################## # Public functions that are not accessible via the stubs table: diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 735874b..cfd7e90 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.187 2006/01/11 17:34:53 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.188 2006/02/01 18:27:43 dgp Exp $ */ #include "tclInt.h" @@ -3246,6 +3246,10 @@ TclEvalObjvInternal( int i; CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case * TCL_EVAL_GLOBAL was set. */ + Namespace *currNsPtr = NULL;/* Used to check for and invoke any + * registered unknown command + * handler for the current namespace + * (see TIP 181). */ int code = TCL_OK; int traceCode = TCL_OK; int checkTraces = 1; @@ -3260,9 +3264,10 @@ TclEvalObjvInternal( /* * Find the function to execute this command. If there isn't one, then see - * if there is a command "unknown". If so, create a new word array with - * "unknown" as the first word and the original command words as - * arguments. Then call ourselves recursively to execute it. + * if there is an unknown command handler registered for this namespace. + * If so, create a new word array with the handler as the first words and + * the original command words as arguments. Then call ourselves + * recursively to execute it. * * If caller requests, or if we're resolving the target end of an * interpeter alias (TCL_EVAL_INVOKE), be sure to do command name @@ -3278,25 +3283,65 @@ TclEvalObjvInternal( iPtr->varFramePtr = NULL; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + /* + * Grab current namespace before restoring var frame, for unknown + * handler check below. + */ + if (iPtr->varFramePtr != NULL && iPtr->varFramePtr->nsPtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + /* Note: assumes globalNsPtr can never be NULL. */ + currNsPtr = iPtr->globalNsPtr; + if (currNsPtr == NULL) { + Tcl_Panic("TclEvalObjvInternal: NULL global namespace pointer"); + } + } iPtr->varFramePtr = savedVarFramePtr; if (cmdPtr == NULL) { - newObjv = (Tcl_Obj **) - ckalloc((unsigned) ((objc + 1) * sizeof(Tcl_Obj *))); - for (i = objc-1; i >= 0; i--) { - newObjv[i+1] = objv[i]; - } - newObjv[0] = Tcl_NewStringObj("::unknown", -1); + int newObjc, handlerObjc; + Tcl_Obj **handlerObjv; + /* + * Check if there is an unknown handler registered for this namespace. + * Otherwise, use the global namespace unknown handler. + */ + if (currNsPtr->unknownHandlerPtr == NULL) { + currNsPtr = iPtr->globalNsPtr; + } + if (currNsPtr == iPtr->globalNsPtr && + currNsPtr->unknownHandlerPtr == NULL) { + /* Global namespace has lost unknown handler, reset. */ + currNsPtr->unknownHandlerPtr = + Tcl_NewStringObj("::unknown", -1); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); + } + if (Tcl_ListObjGetElements(interp, + currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv) + != TCL_OK) { + return TCL_ERROR; + } + newObjc = objc + handlerObjc; + newObjv = (Tcl_Obj **) ckalloc((unsigned) + (newObjc * sizeof(Tcl_Obj *))); + /* Copy command prefix from unknown handler. */ + for (i = 0; i < handlerObjc; ++i) { + newObjv[i] = handlerObjv[i]; + } + /* Add in command name and arguments. */ + for (i = objc-1; i >= 0; --i) { + newObjv[i+handlerObjc] = objv[i]; + } Tcl_IncrRefCount(newObjv[0]); cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); + if (cmdPtr == NULL) { Tcl_AppendResult(interp, "invalid command name \"", TclGetString(objv[0]), "\"", NULL); code = TCL_ERROR; } else { iPtr->numLevels++; - code = TclEvalObjvInternal(interp, objc+1, newObjv, - command, length, 0); + code = TclEvalObjvInternal(interp, newObjc, newObjv, command, + length, 0); iPtr->numLevels--; } Tcl_DecrRefCount(newObjv[0]); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8802438..236a28d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.120 2005/12/27 20:14:08 kennykb Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.121 2006/02/01 18:27:44 dgp Exp $ */ #ifndef _TCLDECLS @@ -3534,6 +3534,19 @@ EXTERN int Tcl_InitBignumFromDouble _ANSI_ARGS_(( Tcl_Interp* interp, double initval, mp_int * toInit)); #endif +#ifndef Tcl_GetNamespaceUnknownHandler_TCL_DECLARED +#define Tcl_GetNamespaceUnknownHandler_TCL_DECLARED +/* 567 */ +EXTERN Tcl_Obj * Tcl_GetNamespaceUnknownHandler _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Namespace * nsPtr)); +#endif +#ifndef Tcl_SetNamespaceUnknownHandler_TCL_DECLARED +#define Tcl_SetNamespaceUnknownHandler_TCL_DECLARED +/* 568 */ +EXTERN int Tcl_SetNamespaceUnknownHandler _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Namespace * nsPtr, + Tcl_Obj * handlerPtr)); +#endif typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -4142,6 +4155,8 @@ typedef struct TclStubs { void (*tcl_SetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); /* 564 */ void (*tcl_GetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); /* 565 */ int (*tcl_InitBignumFromDouble) _ANSI_ARGS_((Tcl_Interp* interp, double initval, mp_int * toInit)); /* 566 */ + Tcl_Obj * (*tcl_GetNamespaceUnknownHandler) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr)); /* 567 */ + int (*tcl_SetNamespaceUnknownHandler) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, Tcl_Obj * handlerPtr)); /* 568 */ } TclStubs; #ifdef __cplusplus @@ -6450,6 +6465,14 @@ extern TclStubs *tclStubsPtr; #define Tcl_InitBignumFromDouble \ (tclStubsPtr->tcl_InitBignumFromDouble) /* 566 */ #endif +#ifndef Tcl_GetNamespaceUnknownHandler +#define Tcl_GetNamespaceUnknownHandler \ + (tclStubsPtr->tcl_GetNamespaceUnknownHandler) /* 567 */ +#endif +#ifndef Tcl_SetNamespaceUnknownHandler +#define Tcl_SetNamespaceUnknownHandler \ + (tclStubsPtr->tcl_SetNamespaceUnknownHandler) /* 568 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index cd224de..0dbb1bd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.265 2006/02/01 17:48:10 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.266 2006/02/01 18:27:46 dgp Exp $ */ #ifndef _TCLINT @@ -263,6 +263,9 @@ typedef struct Namespace { Tcl_Ensemble *ensembles; /* List of structures that contain the details * of the ensembles that are implemented on * top of this namespace. */ + Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command + * resolution in this namespace fails. TIP + * 181. */ int commandPathLength; /* The length of the explicit path. */ NamespacePathEntry *commandPathArray; /* The explicit path of the namespace as an diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 55b6dc1..cf83c02 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -12,6 +12,7 @@ * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2002-2005 Donal K. Fellows. + * Copyright (c) 2006 Neil Madden. * * Originally implemented by * Michael J. McLennan @@ -21,7 +22,7 @@ * 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.92 2006/02/01 17:48:11 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.93 2006/02/01 18:27:47 dgp Exp $ */ #include "tclInt.h" @@ -230,6 +231,9 @@ static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); 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[]); static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -816,6 +820,7 @@ Tcl_CreateNamespace( nsPtr->compiledVarResProc = NULL; nsPtr->exportLookupEpoch = 0; nsPtr->ensembles = NULL; + nsPtr->unknownHandlerPtr = NULL; nsPtr->commandPathLength = 0; nsPtr->commandPathArray = NULL; nsPtr->commandPathSourceList = NULL; @@ -917,6 +922,15 @@ Tcl_DeleteNamespace( } /* + * If the namespace has a registered unknown handler (TIP 181), then free + * it here. + */ + if (nsPtr->unknownHandlerPtr != NULL) { + Tcl_DecrRefCount(nsPtr->unknownHandlerPtr); + nsPtr->unknownHandlerPtr = NULL; + } + + /* * If the namespace is on the call frame stack, it is marked as "dying" * (NS_DYING is OR'd into its flags): the namespace can't be looked up by * name but its commands and variables are still usable by those active @@ -2898,13 +2912,13 @@ Tcl_NamespaceObjCmd( "children", "code", "current", "delete", "ensemble", "eval", "exists", "export", "forget", "import", "inscope", "origin", "parent", "path", "qualifiers", - "tail", "upvar", "which", NULL + "tail", "unknown", "upvar", "which", NULL }; enum NSSubCmdIdx { NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, - NSTailIdx, NSUpvarIdx, NSWhichIdx + NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx }; int index, result; @@ -2975,6 +2989,9 @@ Tcl_NamespaceObjCmd( case NSUpvarIdx: result = NamespaceUpvarCmd(clientData, interp, objc, objv); break; + case NSUnknownIdx: + result = NamespaceUnknownCmd(clientData, interp, objc, objv); + break; case NSWhichIdx: result = NamespaceWhichCmd(clientData, interp, objc, objv); break; @@ -4275,6 +4292,168 @@ NamespaceQualifiersCmd( /* *---------------------------------------------------------------------- * + * NamespaceUnknownCmd -- + * + * Invoked to implement the "namespace unknown" command (TIP 181) that + * sets or queries a per-namespace unknown command handler. This handler + * is called when command lookup fails (current and global ns). The + * default handler for the global namespace is ::unknown. The default + * handler for other namespaces is to call the global namespace unknown + * handler. Passing an empty list results in resetting the handler to + * its default. + * + * namespace unknown ?handler? + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. + * + * Side effects: + * If no handler is specified, returns a result in the interpreter's + * result object, otherwise it sets the unknown handler pointer in the + * current namespace to the script fragment provided. If anything goes + * wrong, the result is an error message. + * + *---------------------------------------------------------------------- + */ +static int +NamespaceUnknownCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Namespace *currNsPtr; + Tcl_Obj *resultPtr; + int rc; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?script?"); + return TCL_ERROR; + } + + currNsPtr = Tcl_GetCurrentNamespace(interp); + + if (objc == 2) { + /* + * Introspection - return the current namespace handler. + */ + resultPtr = Tcl_GetNamespaceUnknownHandler(interp, currNsPtr); + if (resultPtr == NULL) { + resultPtr = Tcl_NewObj(); + } + Tcl_SetObjResult(interp, resultPtr); + } else { + rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[2]); + if (rc == TCL_OK) { + Tcl_SetObjResult(interp, objv[2]); + } + return rc; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetNamespaceUnknownHandler -- + * + * Returns the unknown command handler registered for the given + * namespace. + * + * Results: + * Returns the current unknown command handler, or NULL if none + * exists for the namespace. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj * +Tcl_GetNamespaceUnknownHandler(interp, nsPtr) + Tcl_Interp *interp; /* The interpreter in which the namespace + * exists. */ + Tcl_Namespace *nsPtr; /* The namespace. */ +{ + Namespace *currNsPtr = (Namespace *)nsPtr; + + if (currNsPtr->unknownHandlerPtr == NULL && + currNsPtr == ((Interp *)interp)->globalNsPtr) { + /* Default handler for global namespace is "::unknown". For all + * other namespaces, it is NULL (which falls back on the global + * unknown handler). + */ + currNsPtr->unknownHandlerPtr = + Tcl_NewStringObj("::unknown", -1); + Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); + } + return currNsPtr->unknownHandlerPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetNamespaceUnknownHandler -- + * + * Sets the unknown command handler for the given namespace to the + * command prefix passed. + * + * Results: + * Returns TCL_OK if successful, and TCL_ERROR if anything goes + * wrong. + * + * Side effects: + * Sets the namespace unknown command handler. If the passed in + * handler is NULL or an empty list, then the handler is reset to + * its default. If an error occurs, then an error message is left + * in the interpreter result. + * + *---------------------------------------------------------------------- + */ +int +Tcl_SetNamespaceUnknownHandler(interp, nsPtr, handlerPtr) + Tcl_Interp *interp; /* Interpreter in which the namespace + * exists. */ + Tcl_Namespace *nsPtr; /* Namespace which is being updated. */ + Tcl_Obj *handlerPtr; /* The new handler, or NULL to reset. */ +{ + int lstlen; + Namespace *currNsPtr = (Namespace *)nsPtr; + + if (currNsPtr->unknownHandlerPtr != NULL) { + /* Remove old handler first. */ + Tcl_DecrRefCount(currNsPtr->unknownHandlerPtr); + currNsPtr->unknownHandlerPtr = NULL; + } + /* + * If NULL or an empty list is passed, then reset to the default + * handler. + */ + if (handlerPtr == NULL) { + currNsPtr->unknownHandlerPtr = NULL; + } else { + if (Tcl_ListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) { + /* Not a list */ + return TCL_ERROR; + } else if (lstlen == 0) { + /* Empty list - reset to default. */ + currNsPtr->unknownHandlerPtr = NULL; + } else { + /* + * Increment ref count and store. The reference count is + * decremented either in the code above, or when the namespace + * is deleted. + */ + Tcl_IncrRefCount(handlerPtr); + currNsPtr->unknownHandlerPtr = handlerPtr; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * NamespaceTailCmd -- * * Invoked to implement the "namespace tail" command that returns the diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 88f59e0..7ccef4b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.127 2005/12/27 20:14:09 kennykb Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.128 2006/02/01 18:27:48 dgp Exp $ */ #include "tclInt.h" @@ -1063,6 +1063,8 @@ TclStubs tclStubs = { Tcl_SetChannelError, /* 564 */ Tcl_GetChannelError, /* 565 */ Tcl_InitBignumFromDouble, /* 566 */ + Tcl_GetNamespaceUnknownHandler, /* 567 */ + Tcl_SetNamespaceUnknownHandler, /* 568 */ }; /* !END!: Do not edit above this line. */ diff --git a/tests/namespace.test b/tests/namespace.test index ad7ff10..1acbeb5 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace.test,v 1.52 2006/02/01 17:48:12 dgp Exp $ +# RCS: @(#) $Id: namespace.test,v 1.53 2006/02/01 18:27:48 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -2403,6 +2403,96 @@ test namespace-51.15 {namespace resolution path control} -body { namespace delete ::test_ns_2 } +# TIP 181 - namespace unknown tests +test namespace-52.1 {unknown: default handler ::unknown} { + set result [list [namespace eval foobar { namespace unknown }]] + lappend result [namespace eval :: { namespace unknown }] + namespace delete foobar + set result +} {{} ::unknown} +test namespace-52.2 {unknown: default resolution global} { + proc ::foo {} { return "GLOBAL" } + namespace eval ::bar { proc foo {} { return "NAMESPACE" } } + namespace eval ::bar::jim { proc test {} { foo } } + set result [::bar::jim::test] + namespace delete ::bar + rename ::foo {} + set result +} {GLOBAL} +test namespace-52.3 {unknown: default resolution local} { + proc ::foo {} { return "GLOBAL" } + namespace eval ::bar { + proc foo {} { return "NAMESPACE" } + proc test {} { foo } + } + set result [::bar::test] + namespace delete ::bar + rename ::foo {} + set result +} {NAMESPACE} +test namespace-52.4 {unknown: set handler} { + namespace eval foo { + namespace unknown [list dispatch] + proc dispatch {args} { return $args } + proc test {} { + UnknownCmd a b c + } + } + set result [foo::test] + namespace delete foo + set result +} {UnknownCmd a b c} +test namespace-52.5 {unknown: search path before unknown is unaltered} { + proc ::test2 {args} { return "TEST2: $args" } + namespace eval foo { + namespace unknown [list dispatch] + proc dispatch {args} { return "UNKNOWN: $args" } + proc test1 {args} { return "TEST1: $args" } + proc test {} { + set result [list [test1 a b c]] + lappend result [test2 a b c] + lappend result [test3 a b c] + return $result + } + } + set result [foo::test] + namespace delete foo + rename ::test2 {} + set result +} {{TEST1: a b c} {TEST2: a b c} {UNKNOWN: test3 a b c}} +test namespace-52.6 {unknown: deleting handler restores default} { + rename ::unknown ::_unknown_orig + proc ::unknown {args} { return "DEFAULT: $args" } + namespace eval foo { + namespace unknown dummy + namespace unknown {} + } + set result [namespace eval foo { dummy a b c }] + rename ::unknown {} + rename ::_unknown_orig ::unknown + namespace delete foo + set result +} {DEFAULT: dummy a b c} +test namespace-52.7 {unknown: setting global unknown handler} { + proc ::myunknown {args} { return "MYUNKNOWN: $args" } + namespace eval :: { namespace unknown ::myunknown } + set result [namespace eval foo { dummy a b c }] + namespace eval :: { namespace unknown {} } + rename ::myunknown {} + namespace delete foo + set result +} {MYUNKNOWN: dummy a b c} +test namespace-52.8 {unknown: destroying and redefining global namespace} { + set i [interp create] + $i hide proc + $i hide namespace + $i hide return + $i invokehidden namespace delete :: + $i expose return + $i invokehidden proc unknown args { return "FINE" } + $i eval { foo bar bob } +} {FINE} + # cleanup catch {rename cmd1 {}} catch {unset l} |