diff options
| -rw-r--r-- | jim.c | 38 | ||||
| -rw-r--r-- | tests/upvar.test | 323 |
2 files changed, 348 insertions, 13 deletions
@@ -3765,11 +3765,24 @@ int Jim_SetVariableLink(Jim_Interp *interp, Jim_Obj *nameObjPtr, varName = Jim_GetString(nameObjPtr, &len); - if (Jim_FindHashEntry(&interp->framePtr->vars, varName)) { - Jim_SetResultFormatted(interp, "variable \"%#s\" already exists", nameObjPtr); + if (Jim_NameIsDictSugar(varName, len)) { + Jim_SetResultString(interp, "Dict key syntax invalid as link source", -1); return JIM_ERR; } + /* Check for an existing variable or link */ + if (SetVariableFromAny(interp, nameObjPtr) == JIM_OK) { + Jim_Var *varPtr = nameObjPtr->internalRep.varValue.varPtr; + + if (varPtr->linkFramePtr == NULL) { + Jim_SetResultFormatted(interp, "variable \"%#s\" already exists", nameObjPtr); + return JIM_ERR; + } + + /* It exists, but is a link, so delete the link */ + varPtr->linkFramePtr = NULL; + } + /* Check for cycles. */ if (interp->framePtr == targetCallFrame) { Jim_Obj *objPtr = targetNameObjPtr; @@ -3789,10 +3802,7 @@ int Jim_SetVariableLink(Jim_Interp *interp, Jim_Obj *nameObjPtr, objPtr = varPtr->objPtr; } } - if (Jim_NameIsDictSugar(varName, len)) { - Jim_SetResultString(interp, "Dict key syntax invalid as link source", -1); - return JIM_ERR; - } + /* Perform the binding */ Jim_SetVariable(interp, nameObjPtr, targetNameObjPtr); /* We are now sure 'nameObjPtr' type is variableObjType */ @@ -3822,20 +3832,22 @@ Jim_Obj *Jim_GetVariable(Jim_Interp *interp, Jim_Obj *nameObjPtr, int flags) interp->framePtr = varPtr->linkFramePtr; objPtr = Jim_GetVariable(interp, varPtr->objPtr, flags); interp->framePtr = savedCallFrame; - return objPtr; + if (objPtr) { + return objPtr; + } + /* Error, so fall through to the error message */ } } + break; case JIM_DICT_SUGAR: /* [dict] syntax sugar. */ return JimDictSugarGet(interp, nameObjPtr); - - default: - if (flags & JIM_ERRMSG) { - Jim_SetResultFormatted(interp, "can't read \"%#s\": no such variable", nameObjPtr); - } - return NULL; } + if (flags & JIM_ERRMSG) { + Jim_SetResultFormatted(interp, "can't read \"%#s\": no such variable", nameObjPtr); + } + return NULL; } Jim_Obj *Jim_GetGlobalVariable(Jim_Interp *interp, Jim_Obj *nameObjPtr, int flags) diff --git a/tests/upvar.test b/tests/upvar.test new file mode 100644 index 0000000..cca8360 --- /dev/null +++ b/tests/upvar.test @@ -0,0 +1,323 @@ +# Commands covered: 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 +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# 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.7 2000/04/10 17:19:05 ericm Exp $ + +source testing.tcl + +test upvar-1.1 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.2 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {p3} + proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.3 {reading variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {p3} + proc p3 {} { + upvar #1 a x1 b x2 c x3 d x4 + set a abc + list $x1 $x2 $x3 $x4 $a + } + p1 foo bar +} {foo bar 22 33 abc} +test upvar-1.4 {reading variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} {p2} + proc p2 {} { + upvar 2 x1 x1 x2 a + upvar #0 x1 b + set c $b + incr b 3 + list $x1 $a $b + } + p1 +} {47 55 47} +test upvar-1.5 {reading array elements with upvar} { + proc p1 {} {set a(0) zeroth; set a(1) first; p2} + proc p2 {} {upvar a(0) x; set x} + p1 +} {zeroth} + +test upvar-2.1 {writing variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} + proc p2 {} { + upvar a x1 b x2 c x3 d x4 + set x1 14 + set x4 88 + } + p1 foo bar +} {14 bar 22 88} +test upvar-2.2 {writing variables with upvar} { + set x1 44 + set x2 55 + proc p1 {x1 x2} { + upvar #0 x1 a + upvar x2 b + set a $x1 + set b $x2 + } + p1 newbits morebits + list $x1 $x2 +} {newbits morebits} +test upvar-2.3 {writing variables with upvar} { + catch {unset x1} + catch {unset x2} + proc p1 {x1 x2} { + upvar #0 x1 a + upvar x2 b + set a $x1 + set b $x2 + } + p1 newbits morebits + list [catch {set x1} msg] $msg [catch {set x2} msg] $msg +} {0 newbits 0 morebits} +test upvar-2.4 {writing array elements with upvar} { + proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)} + proc p2 {} {upvar a(0) x; set x xyzzy} + p1 +} {xyzzy xyzzy} + +test upvar-3.1 {unsetting variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} + proc p2 {} { + upvar 1 a x1 d x2 + unset x1 x2 + } + p1 foo bar +} {b c} +test upvar-3.2 {unsetting variables with upvar} { + proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} + proc p2 {} { + upvar 1 a x1 d x2 + unset x1 x2 + set x2 28 + } + p1 foo bar +} {b c d} +test upvar-3.3 {unsetting variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} {p2} + proc p2 {} { + upvar 2 x1 a + upvar #0 x2 b + unset a b + } + p1 + list [info exists x1] [info exists x2] +} {0 0} +test upvar-3.4 {unsetting variables with upvar} { + set x1 44 + set x2 55 + proc p1 {} { + upvar x1 a x2 b + unset a b + set b 118 + } + p1 + list [info exists x1] [catch {set x2} msg] $msg +} {0 0 118} +test upvar-3.5 {unsetting array elements with upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + array names a + } + proc p2 {} {upvar a(0) x; unset x} + p1 +} {1 2} +test upvar-3.6 {unsetting then resetting array elements with upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + list [array names a] [catch {set a(0)} msg] $msg + } + proc p2 {} {upvar a(0) x; unset x; set x 12345} + p1 +} {{0 1 2} 0 12345} + +test upvar-4.1 {nested upvars} { + set x1 88 + proc p1 {a b} {set c 22; set d 33; p2} + proc p2 {} {global x1; upvar c x2; p3} + proc p3 {} { + upvar x1 a x2 b + list $a $b + } + p1 14 15 +} {88 22} +test upvar-4.2 {nested upvars} { + set x1 88 + proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} + proc p2 {} {global x1; upvar c x2; p3} + proc p3 {} { + upvar x1 a x2 b + set a foo + set b bar + } + list [p1 14 15] $x1 +} {{14 15 bar 33} foo} + +proc tproc {args} {global x; set x [list $args [uplevel info vars]]} + +test upvar-6.1 {retargeting an upvar} { + proc p1 {} { + set a(0) zeroth + set a(1) first + set a(2) second + p2 + } + proc p2 {} { + upvar a x + set result {} + foreach i [array names x] { + upvar a($i) x + lappend result $x + } + lsort $result + } + p1 +} {first second zeroth} +test upvar-6.2 {retargeting an upvar} { + set x 44 + set y abcde + proc p1 {} { + global x + set result $x + upvar y x + lappend result $x + } + p1 +} {44 abcde} +test upvar-6.3 {retargeting an upvar} { + set x 44 + set y abcde + proc p1 {} { + upvar y x + lappend result $x + global x + lappend result $x + } + p1 +} {abcde 44} + +test upvar-7.1 {upvar to same level} { + set x 44 + set y 55 + catch {unset uv} + upvar #0 x uv + set uv abc + upvar 0 y uv + set uv xyzzy + list $x $y +} {abc xyzzy} +test upvar-7.2 {upvar to same level} { + set x 1234 + set y 4567 + proc p1 {x y} { + upvar 0 x uv + set uv $y + return "$x $y" + } + p1 44 89 +} {89 89} +test upvar-7.3 {upvar to same level} { + set x 1234 + set y 4567 + proc p1 {x y} { + upvar #1 x uv + set uv $y + return "$x $y" + } + p1 xyz abc +} {abc abc} +test upvar-7.4 {upvar to same level: tricky problems when deleting variable table} { + proc tt {} {upvar #1 toto loc; return $loc} + list [catch tt msg] $msg +} {1 {can't read "loc": no such variable}} +test upvar-7.5 {potential memory leak when deleting variable table} { + proc leak {} { + array set foo {1 2 3 4} + upvar 0 foo(1) bar + } + leak +} {} + +test upvar-8.1 {errors in upvar command} { + catch upvar msg +} 1 +test upvar-8.2 {errors in upvar command} { + catch {upvar 1} +} 1 +test upvar-8.3 {errors in upvar command} { + proc p1 {} {upvar a b c} + catch p1 +} 1 +test upvar-8.4 {errors in upvar command} { + proc p1 {} {upvar 0 b b} + list [catch p1 msg] $msg +} {1 {can't upvar from variable to itself}} +test upvar-8.5 {errors in upvar command} { + proc p1 {} {upvar 0 a b; upvar 0 b a} + list [catch p1 msg] $msg +} {1 {can't upvar from variable to itself}} +test upvar-8.6 {errors in upvar command} { + proc p1 {} {set a 33; upvar b a} + list [catch p1 msg] $msg +} {1 {variable "a" already exists}} +# Jim allows dicts within dicts. Tcl can't do this. +test upvar-8.8 {create nested array with upvar} { + proc p1 {} {upvar x(a) b; set b(2) 44} + catch {unset x} + p1 + set x +} {a {2 44}} +test upvar-8.10 {upvar will create element alias for new array element} { + catch {unset upvarArray} + array set upvarArray {} + catch {upvar 0 upvarArray(elem) upvarArrayElemAlias} +} {0} +test upvar-9.1 {global redefine} { + proc p1 {} { global x; global x } + p1 +} {} +test upvar-9.2 {upvar redefine} { + set a 1 + set b 2 + proc p1 {} { upvar a x; upvar b x; return $x } + p1 +} 2 +test upvar-9.3 {upvar redefine static} { + proc p1 {} {{a 3}} { upvar b a; return $b } + list [catch p1 msg] $msg +} {1 {variable "a" already exists}} +test upvar-9.4 {upvar links to static} { + proc p1 {} {} { upvar a x; incr x; return $x } + proc p2 {} {{a 3}} { list [p1] $a } + p2 +} {4 4} + +catch {unset a} + +testreport |