summaryrefslogtreecommitdiffstats
path: root/generic/tclNamesp.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclNamesp.c')
-rw-r--r--generic/tclNamesp.c185
1 files changed, 182 insertions, 3 deletions
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