TIP#250 IMPLEMENTATION

        * doc/namespace.n:      New command [namespace upvar].  [Patch 1275435]
        * generic/tclInt.h:
        * generic/tclNamesp.c:
        * generic/tclVar.c:
        * tests/namespace.test:
        * tests/upvar.test:

7 files changed, 227 insertions, 35 deletions

diff --git a/ChangeLog b/ChangeLog
index debe429..4b85285 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2006-02-01  Don Porter  <dgp@users.sourceforge.net>
+
+	TIP#250 IMPLEMENTATION
+
+	* doc/namespace.n:	New command [namespace upvar].  [Patch 1275435]
+	* generic/tclInt.h:
+	* generic/tclNamesp.c:
+	* generic/tclVar.c:
+	* tests/namespace.test:
+	* tests/upvar.test:
+
 2006-01-26  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/dict.n: Fixed silly bug in example. Thanks to Heiner Marxen
diff --git a/doc/namespace.n b/doc/namespace.n
index 60bd8e8..f2327a4 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.18 2005/05/30 00:04:45 dkf Exp $
+'\" RCS: @(#) $Id: namespace.n,v 1.19 2006/02/01 17:48:10 dgp Exp $
 '\" 
 .so man.macros
 .TH namespace n 8.5 Tcl "Tcl Built-In Commands"
@@ -249,6 +249,13 @@ This command is the complement of the \fBnamespace qualifiers\fR command.
 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 @@ puts "grill came from [\fBnamespace origin\fR grill]"
 .CE
 
 .SH "SEE ALSO"
-interp(n), variable(n)
+interp(n), upvar(n), variable(n)
 
 .SH KEYWORDS
 command, ensemble, exported, internal, variable
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 895eafd..cd224de 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.264 2005/12/27 20:14:09 kennykb Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.265 2006/02/01 17:48:10 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -2118,6 +2118,9 @@ MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
 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,
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 2debd69..55b6dc1 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -21,7 +21,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.91 2006/01/11 17:34:53 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.92 2006/02/01 17:48:11 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -228,6 +228,8 @@ static int		NamespaceQualifiersCmd(ClientData dummy,
 			    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 @@ Tcl_NamespaceObjCmd(
 	"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 @@ Tcl_NamespaceObjCmd(
 	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 @@ NamespaceTailCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * 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
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 0bf98cf..6ae9d16 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclVar.c,v 1.117 2005/11/27 02:33:49 das Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.118 2006/02/01 17:48:11 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -3204,10 +3204,8 @@ ObjMakeUpvar(
 				 * 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 @@ ObjMakeUpvar(
 	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
diff --git a/tests/namespace.test b/tests/namespace.test
index 83cad11..ad7ff10 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -11,13 +11,18 @@
 # 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.51 2006/01/18 19:48:11 dgp Exp $
+# RCS: @(#) $Id: namespace.test,v 1.52 2006/02/01 17:48:12 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
     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 @@ test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
     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 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} {
     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
diff --git a/tests/upvar.test b/tests/upvar.test
index 2d100a1..0db9404 100644
--- a/tests/upvar.test
+++ b/tests/upvar.test
@@ -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
@@ -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: upvar.test,v 1.10 2004/05/19 10:46:27 dkf Exp $
+# RCS: @(#) $Id: upvar.test,v 1.11 2006/02/01 17:48:13 dgp Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -405,6 +405,50 @@ test upvar-9.7 {Tcl_UpVar procedure} testupvar {
 } {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