diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | doc/namespace.n | 11 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 86 | ||||
| -rw-r--r-- | generic/tclVar.c | 82 | ||||
| -rw-r--r-- | tests/namespace.test | 19 | ||||
| -rw-r--r-- | tests/upvar.test | 48 |
7 files changed, 227 insertions, 35 deletions
@@ -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 |