summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclExecute.c4
-rw-r--r--generic/tclInt.h15
-rw-r--r--generic/tclNamesp.c4
-rw-r--r--generic/tclVar.c55
-rw-r--r--tests/oo.test32
5 files changed, 72 insertions, 38 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 1389382..8ddefda 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4413,8 +4413,8 @@ TEBCresume(
savedNsPtr = iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
- (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
+ (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
+ "access", /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
iPtr->varFramePtr->nsPtr = savedNsPtr;
if (!otherPtr) {
TRACE_ERROR(interp);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a6cc627..4f7ea6e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -170,6 +170,21 @@ typedef struct Tcl_ResolverInfo {
} Tcl_ResolverInfo;
/*
+ * This flag bit should not interfere with TCL_GLOBAL_ONLY,
+ * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable
+ * lookup is performed for upvar (or similar) purposes, with slightly
+ * different rules:
+ * - Bug #696893 - variable is either proc-local or in the current
+ * namespace; never follow the second (global) resolution path
+ * - Bug #631741 - do not use special namespace or interp resolvers
+ *
+ * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag
+ * (Bug #835020)
+ */
+
+#define TCL_AVOID_RESOLVERS 0x40000
+
+/*
*----------------------------------------------------------------
* Data structures related to namespaces.
*----------------------------------------------------------------
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 2c50a60..5930859 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -4538,8 +4538,8 @@ NamespaceUpvarCmd(
savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
otherPtr = TclObjLookupVarEx(interp, objv[0], NULL,
- (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
- /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+ (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
+ "access", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
if (otherPtr == NULL) {
return TCL_ERROR;
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 51e2482..47c6e14 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -742,21 +742,6 @@ TclObjLookupVarEx(
}
/*
- * This flag bit should not interfere with TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable
- * lookup is performed for upvar (or similar) purposes, with slightly
- * different rules:
- * - Bug #696893 - variable is either proc-local or in the current
- * namespace; never follow the second (global) resolution path
- * - Bug #631741 - do not use special namespace or interp resolvers
- *
- * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag
- * (Bug #835020)
- */
-
-#define AVOID_RESOLVERS 0x40000
-
-/*
*----------------------------------------------------------------------
*
* TclLookupSimpleVar --
@@ -805,8 +790,8 @@ TclLookupSimpleVar(
Tcl_Obj *varNamePtr, /* This is a simple variable name that could
* represent a scalar or an array. */
int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
- * AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG bits
- * matter. */
+ * TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG
+ * bits matter. */
const int create, /* If 1, create hash table entry for varname,
* if it doesn't already exist. If 0, return
* error if it doesn't exist. */
@@ -846,7 +831,7 @@ TclLookupSimpleVar(
*/
if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)
- && !(flags & AVOID_RESOLVERS)) {
+ && !(flags & TCL_AVOID_RESOLVERS)) {
resPtr = iPtr->resolverPtr;
if (cxtNsPtr->varResProc) {
result = cxtNsPtr->varResProc(interp, varName,
@@ -899,7 +884,7 @@ TclLookupSimpleVar(
*indexPtr = -1;
flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY;
} else {
- if (flags & AVOID_RESOLVERS) {
+ if (flags & TCL_AVOID_RESOLVERS) {
flags = (flags | TCL_NAMESPACE_ONLY);
}
if (flags & TCL_NAMESPACE_ONLY) {
@@ -914,7 +899,7 @@ TclLookupSimpleVar(
varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr,
(Tcl_Namespace *) cxtNsPtr,
- (flags | AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG);
+ (flags | TCL_AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG);
if (varPtr == NULL) {
Tcl_Obj *tailPtr;
@@ -4396,15 +4381,15 @@ TclPtrObjMakeUpvar(
/*
* Lookup and eventually create the new variable. Set the flag bit
- * AVOID_RESOLVERS to indicate the special resolution rules for upvar
- * purposes:
+ * TCL_AVOID_RESOLVERS to indicate the special resolution rules for
+ * upvar purposes:
* - Bug #696893 - variable is either proc-local or in the current
* namespace; never follow the second (global) resolution path.
* - Bug #631741 - do not use special namespace or interp resolvers.
*/
varPtr = TclLookupSimpleVar(interp, myNamePtr,
- myFlags|AVOID_RESOLVERS, /* create */ 1, &errMsg, &index);
+ myFlags|TCL_AVOID_RESOLVERS, /* create */ 1, &errMsg, &index);
if (varPtr == NULL) {
TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
@@ -5695,11 +5680,12 @@ Tcl_FindNamespaceVar(
* Otherwise, points to namespace in which to
* resolve name. If NULL, look up name in the
* current namespace. */
- int flags) /* An OR'd combination of: AVOID_RESOLVERS,
- * TCL_GLOBAL_ONLY (look up name only in
- * global namespace), TCL_NAMESPACE_ONLY (look
- * up only in contextNsPtr, or the current
- * namespace if contextNsPtr is NULL), and
+ int flags) /* An OR'd combination of:
+ * TCL_AVOID_RESOLVERS, TCL_GLOBAL_ONLY (look
+ * up name only in global namespace),
+ * TCL_NAMESPACE_ONLY (look up only in
+ * contextNsPtr, or the current namespace if
+ * contextNsPtr is NULL), and
* TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
* and TCL_NAMESPACE_ONLY are given,
* TCL_GLOBAL_ONLY is ignored. */
@@ -5725,11 +5711,12 @@ ObjFindNamespaceVar(
* Otherwise, points to namespace in which to
* resolve name. If NULL, look up name in the
* current namespace. */
- int flags) /* An OR'd combination of: AVOID_RESOLVERS,
- * TCL_GLOBAL_ONLY (look up name only in
- * global namespace), TCL_NAMESPACE_ONLY (look
- * up only in contextNsPtr, or the current
- * namespace if contextNsPtr is NULL), and
+ int flags) /* An OR'd combination of:
+ * TCL_AVOID_RESOLVERS, TCL_GLOBAL_ONLY (look
+ * up name only in global namespace),
+ * TCL_NAMESPACE_ONLY (look up only in
+ * contextNsPtr, or the current namespace if
+ * contextNsPtr is NULL), and
* TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
* and TCL_NAMESPACE_ONLY are given,
* TCL_GLOBAL_ONLY is ignored. */
@@ -5759,7 +5746,7 @@ ObjFindNamespaceVar(
cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
- if (!(flags & AVOID_RESOLVERS) &&
+ if (!(flags & TCL_AVOID_RESOLVERS) &&
(cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)) {
resPtr = iPtr->resolverPtr;
diff --git a/tests/oo.test b/tests/oo.test
index 48e093a..2601c37 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -3424,6 +3424,38 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup {
} -cleanup {
foo destroy
} -result {v t}
+test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup {
+ oo::class create Super
+ oo::class create Master {
+ superclass Super
+ variable member1 member2
+ constructor {} {
+ set member1 master1
+ set member2 master2
+ }
+ method getChild {} {
+ Child new [self]
+ }
+ }
+ oo::class create Child {
+ superclass Super
+ variable member1 result
+ constructor {m} {
+ set [namespace current]::member1 child1
+ set ns [info object namespace $m]
+ namespace upvar $ns member1 l1 member2 l2
+ upvar 1 member1 l3 member2 l4
+ [format namespace] upvar $ns member1 l5 member2 l6
+ [format upvar] 1 member1 l7 member2 l8
+ set result [list $l1 $l2 $l3 $l4 $l5 $l6 $l7 $l8]
+ }
+ method result {} {return $result}
+ }
+} -body {
+ [[Master new] getChild] result
+} -cleanup {
+ Super destroy
+} -result {master1 master2 master1 master2 master1 master2 master1 master2}
# A feature that's not supported because the mechanism may change without
# warning, but is supposed to work...
generated by cgit v0.12 at 2024-11-09 12:36:04 (GMT)