Attachment "tip181-3.patch" to
ticket [958222ffff]
added by
tallniel
2004-07-03 07:19:16.
Index: doc/namespace.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/namespace.n,v
retrieving revision 1.14
diff -u -r1.14 namespace.n
--- doc/namespace.n 21 May 2004 22:57:39 -0000 1.14
+++ doc/namespace.n 3 Jul 2004 00:13:12 -0000
@@ -237,6 +237,17 @@
It does not check whether the namespace names are, in fact,
the names of currently defined namespaces.
.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.
Index: doc/unknown.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/unknown.n,v
retrieving revision 1.5
diff -u -r1.5 unknown.n
--- doc/unknown.n 30 May 2004 14:13:52 -0000 1.5
+++ doc/unknown.n 3 Jul 2004 00:13:13 -0000
@@ -23,15 +23,18 @@
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 @@
.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
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.106
diff -u -r1.106 tclBasic.c
--- generic/tclBasic.c 14 Jun 2004 22:14:11 -0000 1.106
+++ generic/tclBasic.c 3 Jul 2004 00:13:24 -0000
@@ -3041,6 +3041,10 @@
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 commmand
+ * handler for the current namespace
+ * (see TIP 181). */
int code = TCL_OK;
int traceCode = TCL_OK;
int checkTraces = 1;
@@ -3059,42 +3063,86 @@
*/
while (1) {
- /*
- * Find the procedure 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.
+ /*
+ * Find the procedure 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 caller requests, or if we're resolving the target end of
* an interpeter alias (TCL_EVAL_INVOKE), be sure to do command
* name resolution in the global namespace.
- */
+ */
savedVarFramePtr = iPtr->varFramePtr;
if (flags & (TCL_EVAL_INVOKE | TCL_EVAL_GLOBAL)) {
iPtr->varFramePtr = NULL;
}
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
+ /*
+ * Grab current namespace before restoring var frame, for unknown
+ * handler check below. Important to grab it here so that we
+ * respect the TCL_EVAL_INVOKE/TCL_EVAL_GLOBAL flags which may
+ * have been passed.
+ */
+ if (iPtr->varFramePtr != NULL && iPtr->varFramePtr->nsPtr != NULL) {
+ currNsPtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ /* Note: Assumes globalNsPtr can never be NULL. */
+ currNsPtr = iPtr->globalNsPtr;
+ }
+ /* Restore var frame. */
iPtr->varFramePtr = savedVarFramePtr;
- if (cmdPtr == NULL) {
+ if (cmdPtr == NULL) {
+ 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 to
+ * default. */
+ 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)
- ((objc + 1) * sizeof (Tcl_Obj *)));
- for (i = objc-1; i >= 0; i--) {
- newObjv[i+1] = objv[i];
+ (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];
}
- newObjv[0] = Tcl_NewStringObj("::unknown", -1);
Tcl_IncrRefCount(newObjv[0]);
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
if (cmdPtr == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ /* Unknown handler doesn't exist. */
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid command name \"", Tcl_GetString(objv[0]), "\"",
(char *) NULL);
- code = TCL_ERROR;
+ code = TCL_ERROR;
} else {
+ /* Evaluate. */
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]);
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.167
diff -u -r1.167 tclInt.h
--- generic/tclInt.h 23 Jun 2004 00:24:42 -0000 1.167
+++ generic/tclInt.h 3 Jul 2004 00:13:31 -0000
@@ -222,6 +222,9 @@
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. See TIP
+ * 181 for details. */
} Namespace;
/*
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.40
diff -u -r1.40 tclNamesp.c
--- generic/tclNamesp.c 25 May 2004 19:45:14 -0000 1.40
+++ generic/tclNamesp.c 3 Jul 2004 00:13:44 -0000
@@ -12,6 +12,7 @@
* Copyright (c) 1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2002-2003 Donal K. Fellows.
+ * Copyright (c) 2004 Neil Madden.
*
* Originally implemented by
* Michael J. McLennan
@@ -232,6 +233,9 @@
static int NamespaceTailCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
+static int NamespaceUnknownCmd _ANSI_ARGS_((
+ ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
static int NamespaceWhichCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
@@ -667,6 +671,7 @@
nsPtr->compiledVarResProc = NULL;
nsPtr->exportLookupEpoch = 0;
nsPtr->ensembles = NULL;
+ nsPtr->unknownHandlerPtr = NULL;
if (parentPtr != NULL) {
entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
@@ -756,6 +761,14 @@
}
/*
+ * If the namespace has a registered unknown handler (TIP 181), then free
+ * it here.
+ */
+ if (nsPtr->unknownHandlerPtr != NULL) {
+ Tcl_DecrRefCount(nsPtr->unknownHandlerPtr);
+ }
+
+ /*
* 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
@@ -2650,13 +2663,13 @@
"children", "code", "current", "delete", "ensemble",
"eval", "exists", "export", "forget", "import",
"inscope", "origin", "parent", "qualifiers",
- "tail", "which", (char *) NULL
+ "tail", "unknown", "which", (char *) NULL
};
enum NSSubCmdIdx {
NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx,
NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
- NSTailIdx, NSWhichIdx
+ NSTailIdx, NSUnknownIdx, NSWhichIdx
};
int index, result;
@@ -2721,6 +2734,9 @@
case NSTailIdx:
result = NamespaceTailCmd(clientData, interp, objc, objv);
break;
+ case NSUnknownIdx:
+ result = NamespaceUnknownCmd(clientData, interp, objc, objv);
+ break;
case NSWhichIdx:
result = NamespaceWhichCmd(clientData, interp, objc, objv);
break;
@@ -3781,6 +3797,114 @@
/*
*----------------------------------------------------------------------
*
+ * 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. */
+{
+ Namespace *currNsPtr;
+ Tcl_Obj *handlerPtr;
+ int lstlen;
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?script?");
+ return TCL_ERROR;
+ }
+
+ currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+
+ if (objc == 2) {
+ /*
+ * Introspection - return the current namespace handler.
+ */
+ if (currNsPtr->unknownHandlerPtr != NULL) {
+ Tcl_SetObjResult(interp, currNsPtr->unknownHandlerPtr);
+ } else {
+ if (currNsPtr->unknownHandlerPtr == NULL) {
+ /*
+ * Default for non-global namespace is "", but for global
+ * namespace is "::unknown". Using these defaults allows
+ * people to do:
+ * set oldns [namespace unknown]
+ * namespace unknown $newns
+ * ...
+ * namespace unknown $oldns
+ *
+ * and it will do the Right Thing.
+ */
+ if (currNsPtr == ((Interp *)interp)->globalNsPtr) {
+ handlerPtr = Tcl_NewStringObj("::unknown", -1);
+ /* Cache this. */
+ currNsPtr->unknownHandlerPtr = handlerPtr;
+ Tcl_IncrRefCount(handlerPtr);
+ } else {
+ handlerPtr = Tcl_NewObj();
+ }
+ } else {
+ handlerPtr = currNsPtr->unknownHandlerPtr;
+ }
+ Tcl_SetObjResult(interp, handlerPtr);
+ }
+ } else {
+ /*
+ * Set the namespace handler.
+ */
+ if (currNsPtr->unknownHandlerPtr != NULL) {
+ /* Remove old handler first. */
+ Tcl_DecrRefCount(currNsPtr->unknownHandlerPtr);
+ }
+ /*
+ * If the empty string is passed, then simply revert to the default
+ * handler.
+ */
+ if (Tcl_ListObjLength(interp, objv[2], &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(objv[2]);
+ currNsPtr->unknownHandlerPtr = objv[2];
+ Tcl_SetObjResult(interp, objv[2]);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* NamespaceTailCmd --
*
* Invoked to implement the "namespace tail" command that returns the
Index: tests/namespace.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/namespace.test,v
retrieving revision 1.28
diff -u -r1.28 namespace.test
--- tests/namespace.test 25 May 2004 19:45:17 -0000 1.28
+++ tests/namespace.test 3 Jul 2004 00:13:49 -0000
@@ -655,7 +655,7 @@
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} {
list [catch {namespace wombat {}} msg] $msg
-} {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
+} {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, unknown, or which}}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
namespace ch :: test_ns_*
} {}
@@ -762,7 +762,7 @@
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} {
list [catch {namespace test_ns_1} msg] $msg
-} {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
+} {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, unknown, or which}}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123
@@ -1649,6 +1649,87 @@
while parsing result of ensemble unknown subcommand handler
invoked from within
"foo bar"}}
+# TIP 181 - namespace unknown tests
+test namespace-48.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-48.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-48.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-48.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-48.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-48.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-48.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}
+
+
# cleanup
catch {rename cmd1 {}}