Attachment "1706140-2.patch" to
ticket [1706140fff]
added by
msofer
2007-05-04 12:50:25.
Index: generic/tclLink.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclLink.c,v
retrieving revision 1.21
diff -u -r1.21 tclLink.c
--- generic/tclLink.c 10 Apr 2007 14:47:16 -0000 1.21
+++ generic/tclLink.c 4 May 2007 05:44:21 -0000
@@ -262,7 +262,7 @@
*/
if (flags & TCL_TRACE_UNSETS) {
- if (flags & TCL_INTERP_DESTROYED) {
+ if (Tcl_InterpDeleted(interp)) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.133
diff -u -r1.133 tclNamesp.c
--- generic/tclNamesp.c 24 Apr 2007 17:50:53 -0000 1.133
+++ generic/tclNamesp.c 4 May 2007 05:44:24 -0000
@@ -622,7 +622,7 @@
{
Interp *iPtr = (Interp *)interp;
- if (flags & TCL_INTERP_DESTROYED) {
+ if (Tcl_InterpDeleted(interp)) {
return NULL;
}
if (iPtr->errorCode) {
@@ -696,7 +696,7 @@
{
Interp *iPtr = (Interp *)interp;
- if (flags & TCL_INTERP_DESTROYED) {
+ if (Tcl_InterpDeleted(interp)) {
return NULL;
}
if (iPtr->errorInfo) {
Index: generic/tclTrace.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTrace.c,v
retrieving revision 1.36
diff -u -r1.36 tclTrace.c
--- generic/tclTrace.c 10 Apr 2007 14:47:17 -0000 1.36
+++ generic/tclTrace.c 4 May 2007 05:44:26 -0000
@@ -1269,7 +1269,7 @@
tcmdPtr->refCount++;
- if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)
+ if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)
&& !Tcl_LimitExceeded(interp)) {
/*
* Generate a command to execute by appending list elements for the
@@ -1750,7 +1750,7 @@
return traceCode;
}
- if (!(flags & TCL_INTERP_DESTROYED) && !Tcl_LimitExceeded(interp)) {
+ if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) {
/*
* Check whether the current call is going to eval arbitrary Tcl code
* with a generated trace, or whether we are only going to setup
@@ -1958,7 +1958,7 @@
*/
result = NULL;
- if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)
+ if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)
&& !Tcl_LimitExceeded(interp)) {
if (tvarPtr->length != (size_t) 0) {
/*
@@ -2457,10 +2457,8 @@
CONST char *part1,
CONST char *part2, /* Variable's two-part name. */
int flags, /* Flags passed to trace functions: indicates
- * what's happening to variable, plus other
- * stuff like TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY, and
- * TCL_INTERP_DESTROYED. */
+ * what's happening to variable, plus maybe
+ * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */
int leaveErrMsg) /* If true, and one of the traces indicates an
* error, then leave an error message and
* stack trace information in *iPTr. */
@@ -2543,6 +2541,9 @@
if (state == NULL) {
state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
}
+ if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
+ flags |= TCL_INTERP_DESTROYED;
+ }
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
@@ -2582,6 +2583,9 @@
if (state == NULL) {
state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code);
}
+ if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
+ flags |= TCL_INTERP_DESTROYED;
+ }
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
Index: generic/tclUtil.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclUtil.c,v
retrieving revision 1.81
diff -u -r1.81 tclUtil.c
--- generic/tclUtil.c 21 Mar 2007 18:02:51 -0000 1.81
+++ generic/tclUtil.c 4 May 2007 05:44:27 -0000
@@ -2143,7 +2143,7 @@
*/
if (flags & TCL_TRACE_UNSETS) {
- if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
+ if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) {
Tcl_TraceVar2(interp, name1, name2,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
Index: generic/tclVar.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclVar.c,v
retrieving revision 1.133
diff -u -r1.133 tclVar.c
--- generic/tclVar.c 2 May 2007 00:31:22 -0000 1.133
+++ generic/tclVar.c 4 May 2007 05:44:30 -0000
@@ -1097,15 +1097,10 @@
{
Var *varPtr, *arrayPtr;
- /*
- * We need a special flag check to see if we want to create part 1,
- * because commands like lappend require read traces to trigger for
- * previously non-existent values.
- */
-
+ /* Filter to pass through only the flags this interface supports. */
+ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
varPtr = TclLookupVar(interp, part1, part2, flags, "read",
- /*createPart1*/ (flags & TCL_TRACE_READS),
- /*createPart2*/ 1, &arrayPtr);
+ /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
@@ -1155,15 +1150,10 @@
part1 = TclGetString(part1Ptr);
part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr));
- /*
- * We need a special flag check to see if we want to create part 1,
- * because commands like lappend require read traces to trigger for
- * previously non-existent values.
- */
-
+ /* Filter to pass through only the flags this interface supports. */
+ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
- /*createPart1*/ (flags & TCL_TRACE_READS),
- /*createPart2*/ 1, &arrayPtr);
+ /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
@@ -1453,6 +1443,9 @@
{
Var *varPtr, *arrayPtr;
+ /* Filter to pass through only the flags this interface supports. */
+ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
+ |TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
varPtr = TclLookupVar(interp, part1, part2, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
@@ -1512,6 +1505,9 @@
part1 = TclGetString(part1Ptr);
part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr));
+ /* Filter to pass through only the flags this interface supports. */
+ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
+ |TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
@@ -1603,7 +1599,8 @@
/*
* Invoke any read traces that have been set for the variable if it is
- * requested; this is only done in the core when lappending.
+ * requested; this is only done in the core by the INST_LAPPEND_*
+ * instructions.
*/
if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL)
@@ -1936,6 +1933,8 @@
part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
+ /* Filter to pass through only the flags this interface supports. */
+ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
TclDecrRefCount(part1Ptr);
@@ -2121,8 +2120,8 @@
if ((dummyVar.tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
dummyVar.flags &= ~VAR_TRACE_ACTIVE;
- TclCallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
- (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_INTERP_DESTROYED))
+ TclCallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2, (flags
+ & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
| TCL_TRACE_UNSETS, /* leaveErrMsg */ 0);
while (dummyVar.tracePtr != NULL) {
VarTrace *tracePtr = dummyVar.tracePtr;
@@ -2146,21 +2145,8 @@
dummyVarPtr = &dummyVar;
if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) {
- /*
- * Deleting the elements of the array may cause traces to be fired on
- * those elements. Before deleting them, bump the reference count of
- * the array, so that if those trace procs make a global or upvar link
- * to the array, the array is not deleted when the call stack gets
- * popped (we will delete the array ourselves later in this function).
- *
- * Bumping the count can lead to the odd situation that elements of
- * the array are being deleted when the array still exists, but since
- * the array is about to be removed anyway, that shouldn't really
- * matter.
- */
-
- DeleteArray(iPtr, part1, dummyVarPtr,
- (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
+ DeleteArray(iPtr, part1, dummyVarPtr, (flags
+ & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
| TCL_TRACE_UNSETS);
/*
@@ -2390,10 +2376,7 @@
createdNewObj = 0;
/*
- * Use the TCL_TRACE_READS flag to ensure that if we have an array
- * with no elements set yet, but with a read trace on it, we will
- * create the variable and get read traces triggered. Note that you
- * have to protect the variable pointers around the TclPtrGetVar call
+ * Protect the variable pointers around the TclPtrGetVar call
* to insure that they remain valid even if the variable was undefined
* and unused.
*/
@@ -2409,7 +2392,7 @@
}
part1 = TclGetString(objv[1]);
varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL,
- (TCL_TRACE_READS | TCL_LEAVE_ERR_MSG));
+ TCL_LEAVE_ERR_MSG);
varPtr->refCount--;
if (arrayPtr != NULL) {
arrayPtr->refCount--;
@@ -4078,9 +4061,6 @@
} else if (nsPtr == (Namespace *) Tcl_GetCurrentNamespace(interp)) {
flags = TCL_NAMESPACE_ONLY;
}
- if (Tcl_InterpDeleted(interp)) {
- flags |= TCL_INTERP_DESTROYED;
- }
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_FirstHashEntry(tablePtr, &search)) {
@@ -4158,9 +4138,6 @@
} else if (tablePtr == &currNsPtr->varTable) {
flags |= TCL_NAMESPACE_ONLY;
}
- if (Tcl_InterpDeleted(interp)) {
- flags |= TCL_INTERP_DESTROYED;
- }
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
@@ -4389,8 +4366,7 @@
Var *varPtr, /* Pointer to variable structure. */
int flags) /* Flags to pass to TclCallVarTraces:
* TCL_TRACE_UNSETS and sometimes
- * TCL_INTERP_DESTROYED, TCL_NAMESPACE_ONLY,
- * or TCL_GLOBAL_ONLY. */
+ * TCL_NAMESPACE_ONLY or TCL_GLOBAL_ONLY. */
{
Tcl_HashSearch search;
register Tcl_HashEntry *hPtr;
