From dc96ed26b28e9e72bbd56400aaf060f15d93fa25 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 17 Nov 2000 11:06:52 +0000 Subject: Finally fixed bug 119192. This was a real nasty that was hidden by the fact that it never caused a crash and was blocked most of the time from coming into play by the way the compiler handles array variable references. (Yes, the test suite does pass now on this machine at least...) FossilOrigin-Name: e927e40de9d37218ed8b3dbc08e5363d239efd26 --- ChangeLog | 13 ++++++++++--- generic/tclVar.c | 39 +++++++++++++++------------------------ tests/safe.test | 4 ++-- 3 files changed, 27 insertions(+), 29 deletions(-) diff --git a/ChangeLog b/ChangeLog index 7b6e64f..8d046c8 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,8 +1,15 @@ 2000-11-17 Donal K. Fellows - * tests/var.test: (test var-1.19) If my attempts to fix the - problem aren't right yet, my attempts to describe it look pretty - good to me... + * tests/safe.test: (safe-4.3): + * generic/tclVar.c (TclLookupVar): Changed again. Now passes all + the tests, though one needed modifying since it required the wrong + answer. (Why on earth do we have inline modification of argument + strings? This sort of thing is horrendous to debug and doesn't + work well in a multithreaded environment!) Fixes bug 119192. + + * tests/var.test: (var-1.19) If my attempts to fix the problem + aren't right yet, my attempts to describe it look pretty good to + me... 2000-11-16 Andreas Kupries diff --git a/generic/tclVar.c b/generic/tclVar.c index 6b32fe3..c160c84 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -14,7 +14,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.26 2000/11/15 22:19:56 hobbs Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.27 2000/11/17 11:06:53 dkf Exp $ */ #include "tclInt.h" @@ -177,6 +177,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } closeParen = p; *openParen = 0; + *closeParen = 0; elName = openParen+1; } else { openParen = NULL; @@ -219,7 +220,10 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, varPtr = (Var *) var; goto lookupVarPart2; } else if (result != TCL_CONTINUE) { - return (Var *) NULL; + varPtr = (Var *) NULL; + /* can't just return here as input string is in an + * inconsistent state... */ + goto done; } } @@ -262,13 +266,13 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (varNsPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, badNamespace); + VarErrMsg(interp, part1, elName, msg, badNamespace); } goto done; } if (tail == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, missingName); + VarErrMsg(interp, part1, elName, msg, missingName); } goto done; } @@ -279,7 +283,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, varPtr->nsPtr = varNsPtr; } else { /* var wasn't found and not to create it */ if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); + VarErrMsg(interp, part1, elName, msg, noSuchVar); } goto done; } @@ -329,7 +333,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } if (hPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); + VarErrMsg(interp, part1, elName, msg, noSuchVar); } goto done; } @@ -339,11 +343,6 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } lookupVarPart2: - if (openParen != NULL) { - *openParen = '('; - openParen = NULL; - } - /* * If varPtr is a link variable, we have a reference to some variable * that was created through an "upvar" or "global" command. Traverse @@ -370,7 +369,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (TclIsVarUndefined(varPtr) && !TclIsVarArrayElement(varPtr)) { if (!createPart1) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); + VarErrMsg(interp, part1, elName, msg, noSuchVar); } varPtr = NULL; goto done; @@ -382,7 +381,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, */ if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, danglingVar); + VarErrMsg(interp, part1, elName, msg, danglingVar); } varPtr = NULL; goto done; @@ -395,20 +394,14 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); } else if (!TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, needArray); + VarErrMsg(interp, part1, elName, msg, needArray); } varPtr = NULL; goto done; } *arrayPtrPtr = varPtr; - if (closeParen != NULL) { - *closeParen = 0; - } if (createPart2) { hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new); - if (closeParen != NULL) { - *closeParen = ')'; - } if (new) { if (varPtr->searchPtr != NULL) { DeleteSearches(varPtr); @@ -421,12 +414,9 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } } else { hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName); - if (closeParen != NULL) { - *closeParen = ')'; - } if (hPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchElement); + VarErrMsg(interp, part1, elName, msg, noSuchElement); } varPtr = NULL; goto done; @@ -437,6 +427,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, done: if (openParen != NULL) { *openParen = '('; + *closeParen = ')'; } return varPtr; } diff --git a/tests/safe.test b/tests/safe.test index 641fe9d..2eb6788 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.test,v 1.9 2000/04/10 17:19:04 ericm Exp $ +# RCS: @(#) $Id: safe.test,v 1.10 2000/11/17 11:06:54 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -122,7 +122,7 @@ test safe-4.3 {safe::interpDelete, state array (not a public api)} { catch {namespace eval safe {set [InterpStateName a](foo)}} m2 list $m1 $m2 } "{}\ - {can't read \"[safe::InterpStateName a]\": no such variable}" + {can't read \"[safe::InterpStateName a](foo)\": no such variable}" test safe-4.4 {safe::interpDelete, state array, indirectly (not a public api)} { -- cgit v0.12