summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2006-02-01 18:27:42 (GMT)
committerdgp <dgp@users.sourceforge.net>2006-02-01 18:27:42 (GMT)
commitbf2e20ec8703a3c6e725e464bb4e7fca8af0834c (patch)
treec00a6c3b557759767b41407974391d1117ad0c25
parent2e9bf45bc4d2510a07a538c48f8103957ede3aaf (diff)
downloadtcl-bf2e20ec8703a3c6e725e464bb4e7fca8af0834c.zip
tcl-bf2e20ec8703a3c6e725e464bb4e7fca8af0834c.tar.gz
tcl-bf2e20ec8703a3c6e725e464bb4e7fca8af0834c.tar.bz2
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:
-rw-r--r--ChangeLog14
-rw-r--r--doc/Namespace.320
-rw-r--r--doc/namespace.n13
-rw-r--r--doc/unknown.n21
-rw-r--r--generic/tcl.decls15
-rw-r--r--generic/tclBasic.c69
-rw-r--r--generic/tclDecls.h25
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclNamesp.c185
-rw-r--r--generic/tclStubInit.c4
-rw-r--r--tests/namespace.test92
11 files changed, 430 insertions, 33 deletions
diff --git a/ChangeLog b/ChangeLog
index 4b85285..b4c1000 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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}