Attachment "tip181-2.patch" to
ticket [958222ffff]
added by
nobody
2004-05-22 03:59:12.
Index: doc/namespace.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/namespace.n,v
retrieving revision 1.13
diff -u -r1.13 namespace.n
--- doc/namespace.n 9 Mar 2004 12:59:04 -0000 1.13
+++ doc/namespace.n 21 May 2004 20:11:59 -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.4
diff -u -r1.4 unknown.n
--- doc/unknown.n 27 Jun 2001 21:00:45 -0000 1.4
+++ doc/unknown.n 21 May 2004 20:12:00 -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
@@ -73,7 +76,7 @@
executed.
.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.102
diff -u -r1.102 tclBasic.c
--- generic/tclBasic.c 20 May 2004 13:04:11 -0000 1.102
+++ generic/tclBasic.c 21 May 2004 20:12:11 -0000
@@ -9,13 +9,13 @@
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2004 Neil Madden.
*
* 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.102 2004/05/20 13:04:11 dkf Exp $
*/
-
#include "tclInt.h"
#include "tclCompile.h"
@@ -3042,6 +3042,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;
@@ -3077,15 +3081,48 @@
iPtr->varFramePtr = NULL;
}
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) {
+ currNsPtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ /* globalNsPtr can never be NULL. */
+ currNsPtr = iPtr->globalNsPtr;
+ }
+ /* Restore var frame. */
iPtr->varFramePtr = savedVarFramePtr;
if (cmdPtr == NULL) {
+ int newObjc, handlerObjc;
+ Tcl_Obj **handlerObjv;
+ /*
+ * Check if there is an unknown handler registered for this
+ * namespace.
+ */
+ if (currNsPtr->unknownHandlerPtr == NULL) {
+ 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 *)));
+ (newObjc * sizeof (Tcl_Obj *)));
+ for (i = 0; i < handlerObjc; i++) {
+ newObjv[i] = handlerObjv[i];
+ }
for (i = objc-1; i >= 0; i--) {
- newObjv[i+1] = objv[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) {
@@ -3095,7 +3132,7 @@
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]);
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.161
diff -u -r1.161 tclInt.h
--- generic/tclInt.h 20 May 2004 13:04:11 -0000 1.161
+++ generic/tclInt.h 21 May 2004 20:12:18 -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.37
diff -u -r1.37 tclNamesp.c
--- generic/tclNamesp.c 24 Mar 2004 21:54:32 -0000 1.37
+++ generic/tclNamesp.c 21 May 2004 20:12:30 -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,94 @@
/*
*----------------------------------------------------------------------
*
+ * 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 in the current namespace fails. The
+ * default handler for namespaces (hard-coded into TclEvalObjvInternal)
+ * simply searches the global namespace. The default handler for the
+ * global namespace calls a command named "::unknown". This behaviour is
+ * fully backwards-compatible with Tcl pre-TIP-181. Handles the following
+ * syntax:
+ *
+ * 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;
+
+ 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 {
+ /*
+ * Default unknown handler for any ns is ::unknown. Cache the
+ * result (may as well).
+ */
+ handlerPtr = Tcl_NewStringObj("::unknown", -1);
+ currNsPtr->unknownHandlerPtr = handlerPtr;
+ Tcl_IncrRefCount(handlerPtr);
+ 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_GetCharLength(objv[2]) == 0) {
+ 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.24
diff -u -r1.24 namespace.test
--- tests/namespace.test 24 Mar 2004 21:54:32 -0000 1.24
+++ tests/namespace.test 21 May 2004 20:12:42 -0000
@@ -641,7 +641,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_*
} {}
@@ -748,7 +748,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
@@ -1634,6 +1634,77 @@
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 [namespace eval foobar { namespace unknown }]
+ lappend result [namespace eval :: { namespace unknown }]
+ namespace delete foobar
+ set result
+} {::unknown ::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}
+
# cleanup
catch {rename cmd1 {}}
