Attachment "1275435.patch" to
ticket [1275435fff]
added by
dgp
2006-01-18 23:38:01.
Index: doc/namespace.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/namespace.n,v
retrieving revision 1.18
diff -u -r1.18 namespace.n
--- doc/namespace.n 30 May 2005 00:04:45 -0000 1.18
+++ doc/namespace.n 18 Jan 2006 16:37:01 -0000
@@ -249,6 +249,13 @@
It does not check whether the namespace names are, in fact,
the names of currently defined namespaces.
.TP
+\fBnamespace upvar\fR \fInamespace\fR \fIotherVar myVar \fR?\fIotherVar myVar \fR...
+This command arranges for one or more local variables in the current
+procedure to refer to variables in \fInamespace\fR. The command
+\fBnamespace upvar $ns a b\fR has the same behaviour as
+\fBupvar 0 $ns::a b\fR.
+\fBnamespace upvar\fR returns an empty string.
+.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.
@@ -812,7 +819,7 @@
.CE
.SH "SEE ALSO"
-interp(n), variable(n)
+interp(n), upvar(n), variable(n)
.SH KEYWORDS
command, ensemble, exported, internal, variable
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.264
diff -u -r1.264 tclInt.h
--- generic/tclInt.h 27 Dec 2005 20:14:09 -0000 1.264
+++ generic/tclInt.h 18 Jan 2006 16:37:02 -0000
@@ -2118,6 +2118,9 @@
MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[],
Tcl_Namespace *nsPtr, int flags);
+MODULE_SCOPE int TclPtrMakeUpvar (Tcl_Interp *interp,
+ Var *otherP1Ptr, CONST char *myName,
+ int myFlags, int index);
MODULE_SCOPE int TclObjPrintf(Tcl_Interp *interp, Tcl_Obj *objPtr,
CONST char *format, ...);
MODULE_SCOPE int TclParseBackslash(CONST char *src,
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.91
diff -u -r1.91 tclNamesp.c
--- generic/tclNamesp.c 11 Jan 2006 17:34:53 -0000 1.91
+++ generic/tclNamesp.c 18 Jan 2006 16:37:02 -0000
@@ -228,6 +228,8 @@
Tcl_Interp *interp,int objc,Tcl_Obj *CONST objv[]);
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 NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]);
static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
@@ -2896,13 +2898,13 @@
"children", "code", "current", "delete", "ensemble",
"eval", "exists", "export", "forget", "import",
"inscope", "origin", "parent", "path", "qualifiers",
- "tail", "which", NULL
+ "tail", "upvar", "which", NULL
};
enum NSSubCmdIdx {
NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx,
NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx,
- NSTailIdx, NSWhichIdx
+ NSTailIdx, NSUpvarIdx, NSWhichIdx
};
int index, result;
@@ -2969,6 +2971,9 @@
break;
case NSTailIdx:
result = NamespaceTailCmd(clientData, interp, objc, objv);
+ break;
+ case NSUpvarIdx:
+ result = NamespaceUpvarCmd(clientData, interp, objc, objv);
break;
case NSWhichIdx:
result = NamespaceWhichCmd(clientData, interp, objc, objv);
@@ -4332,6 +4337,81 @@
/*
*----------------------------------------------------------------------
*
+ * NamespaceUpvarCmd --
+ *
+ * Invoked to implement the "namespace upvar" command, that creates
+ * variables in the current scope linked to variables in another
+ * namespace. Handles the following syntax:
+ *
+ * namespace upvar ns otherVar myVar ?otherVar myVar ...?
+ *
+ * Results:
+ * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
+ *
+ * Side effects:
+ * Creates new variables in the current scope, linked to the
+ * corresponding variables in the stipulated nmamespace.
+ * If anything goes wrong, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NamespaceUpvarCmd(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 *nsPtr;
+ int result;
+ Var *otherPtr, *arrayPtr;
+ char *myName;
+ CallFrame frame, *framePtr = &frame;
+
+ if (objc < 5 || !(objc & 1)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "ns otherVar myVar ?otherVar myVar ...?");
+ return TCL_ERROR;
+ }
+
+ result = TclGetNamespaceFromObj(interp, objv[2], &nsPtr);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ objc -= 3;
+ objv += 3;
+
+ for (; objc>0 ; objc-=2, objv+=2) {
+ /*
+ * Locate the other variable
+ */
+ Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, nsPtr, 0);
+ otherPtr = TclObjLookupVar(interp, objv[0], NULL,
+ (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
+ /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ if (otherPtr == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_PopCallFrame(interp);
+
+ /*
+ * Create the new variable and link it to otherPtr
+ */
+
+ myName = TclGetString(objv[1]);
+ result = TclPtrMakeUpvar(interp, otherPtr, myName, 0, -1);
+ if (result != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* NamespaceWhichCmd --
*
* Invoked to implement the "namespace which" command that returns the
Index: generic/tclVar.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclVar.c,v
retrieving revision 1.117
diff -u -r1.117 tclVar.c
--- generic/tclVar.c 27 Nov 2005 02:33:49 -0000 1.117
+++ generic/tclVar.c 18 Jan 2006 16:37:03 -0000
@@ -3204,10 +3204,8 @@
* scalar, this is its index. Otherwise, -1 */
{
Interp *iPtr = (Interp *) interp;
- Var *otherPtr, *varPtr, *arrayPtr;
+ Var *otherPtr, *arrayPtr;
CallFrame *varFramePtr;
- CONST char *errMsg;
- CONST char *p;
/*
* Find "other" in "framePtr". If not looking up other in just the current
@@ -3229,30 +3227,74 @@
return TCL_ERROR;
}
- if (index >= 0) {
- if (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
- Tcl_Panic("ObjMakeUpvar called with an index outside from a proc.\n");
- }
- varPtr = &(varFramePtr->compiledLocals[index]);
- } else {
- /*
- * Check that we are not trying to create a namespace var linked to a
- * local variable in a procedure. If we allowed this, the local
- * variable in the shorter-lived procedure frame could go away leaving
- * the namespace var's reference invalid.
- */
+ /*
+ * Check that we are not trying to create a namespace var linked to a
+ * local variable in a procedure. If we allowed this, the local
+ * variable in the shorter-lived procedure frame could go away leaving
+ * the namespace var's reference invalid.
+ */
+ if (index < 0) {
if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL)
- && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
- || (varFramePtr == NULL)
- || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
- || (strstr(myName, "::") != NULL))) {
+ && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
+ || (varFramePtr == NULL)
+ || !(varFramePtr->isProcCallFrame & FRAME_IS_PROC)
+ || (strstr(myName, "::") != NULL))) {
Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
myName, "\": upvar won't create namespace variable that ",
"refers to procedure variable", NULL);
return TCL_ERROR;
}
+ }
+ return TclPtrMakeUpvar(interp, otherPtr, myName, myFlags, index);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPtrMakeUpvar --
+ *
+ * This procedure does all of the work of the "global" and "upvar"
+ * commands.
+ *
+ * Results:
+ * A standard Tcl completion code. If an error occurs then an error
+ * message is left in iPtr->result.
+ *
+ * Side effects:
+ * The variable given by myName is linked to the variable in framePtr
+ * given by otherP1 and otherP2, so that references to myName are
+ * redirected to the other variable like a symbolic link.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPtrMakeUpvar(interp, otherPtr, myName, myFlags, index)
+ Tcl_Interp *interp; /* Interpreter containing variables. Used for
+ * error messages, too. */
+ Var *otherPtr; /* Pointer to the variable being linked-to */
+ CONST char *myName; /* Name of variable which will refer to
+ * otherP1/otherP2. Must be a scalar. */
+ int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
+ * indicates scope of myName. */
+ int index; /* If the variable to be linked is an indexed
+ * scalar, this is its index. Otherwise, -1 */
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ Var *varPtr;
+ CONST char *errMsg;
+ CONST char *p;
+
+ if (index >= 0) {
+ if (!(varFramePtr->isProcCallFrame & FRAME_IS_PROC)) {
+ Tcl_Panic("ObjMakeUpvar called with an index outside from a proc.\n");
+ }
+ varPtr = &(varFramePtr->compiledLocals[index]);
+ } else {
/*
* Do not permit the new variable to look like an array reference, as
* it will not be reachable in that case [Bug 600812, TIP 184]. The
Index: tests/namespace.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/namespace.test,v
retrieving revision 1.50
diff -u -r1.50 namespace.test
--- tests/namespace.test 9 Jan 2006 18:35:01 -0000 1.50
+++ tests/namespace.test 18 Jan 2006 16:37:04 -0000
@@ -18,6 +18,11 @@
namespace import -force ::tcltest::*
}
+#
+# REMARK: the tests for 'namespace upvar' are not done here. They are to be
+# found in the file 'upvar.test'.
+#
+
# Clear out any namespaces called test_ns_*
catch {namespace delete {expand}[namespace children :: test_ns_*]}
@@ -871,9 +876,9 @@
catch {namespace delete {expand}[namespace children :: test_ns_*]}
list [catch {namespace} msg] $msg
} {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, path, qualifiers, tail, or which}}
+test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} -body {
+ namespace wombat {}
+} -returnCodes error -match glob -result {bad option "wombat": must be *}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
namespace ch :: test_ns_*
} {}
@@ -978,9 +983,9 @@
catch {namespace delete {expand}[namespace children :: test_ns_*]}
list [catch {namespace eval} msg] $msg
} {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, path, qualifiers, tail, or which}}
+test namespace-25.2 {NamespaceEvalCmd, bad args} -body {
+ namespace test_ns_1
+} -returnCodes error -match glob -result {bad option "test_ns_1": must be *}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123
Index: tests/upvar.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/upvar.test,v
retrieving revision 1.10
diff -u -r1.10 upvar.test
--- tests/upvar.test 19 May 2004 10:46:27 -0000 1.10
+++ tests/upvar.test 18 Jan 2006 16:37:04 -0000
@@ -1,4 +1,4 @@
-# Commands covered: upvar
+# Commands covered: 'upvar', 'namespace upvar'
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
@@ -405,6 +405,50 @@
} {1234}
catch {unset a}
+
+#
+# Tests for 'namespace upvar'. As the implementation is essentially the same as
+# for 'upvar', we only test that the variables are linked correctly. Ie, we
+# assume that the behaviour of variables once the link is established has
+# already been tested above.
+#
+
+# Clear out any namespaces called test_ns_*
+catch {namespace delete {expand}[namespace children :: test_ns_*]}
+
+namespace eval test_ns_0 {
+ variable x test_ns_0
+}
+
+namespace eval test_ns_1 {
+ variable x test_ns_1
+}
+
+namespace eval test_ns_2 {}
+
+set x test_global
+
+test upvar-NS-1.1 {nsupvar links to correct variable} \
+ -body {
+ namespace eval test_ns_2 {
+ namespace upvar ::test_ns_0 x w
+ set w
+ }
+ } \
+ -result {test_ns_0}
+
+test upvar-NS-1.2 {nsupvar links to correct variable} \
+ -body {
+ namespace eval test_ns_2 {
+ proc a {} {
+ namespace upvar ::test_ns_0 x w
+ set w
+ }
+ return [a][rename a {}]
+ }
+ } \
+ -result {test_ns_0}
+
# cleanup
::tcltest::cleanupTests
return
