summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2012-06-11 17:49:12 (GMT)
committerdgp <dgp@users.sourceforge.net>2012-06-11 17:49:12 (GMT)
commit2b44404206c55f2894ce4b297fbce6176a70cf66 (patch)
tree2de722a252b06dbff9c8bac7239a3b99d8fcbf85
parente39d5419c36351fd1e67f48b94934998ddf15785 (diff)
parent45d29cd41c215484eaf33a4f02be315a6b1872b9 (diff)
downloadtcl-2b44404206c55f2894ce4b297fbce6176a70cf66.zip
tcl-2b44404206c55f2894ce4b297fbce6176a70cf66.tar.gz
tcl-2b44404206c55f2894ce4b297fbce6176a70cf66.tar.bz2
3532959 Make sure the lifetime management of entries in the linePBodyPtr hash
table can tolerate either order of teardown, interp first, or Proc first.
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclBasic.c12
-rw-r--r--generic/tclProc.c28
-rw-r--r--tests/proc.test9
4 files changed, 39 insertions, 17 deletions
diff --git a/ChangeLog b/ChangeLog
index 378b0ae..4ac5205 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2012-06-11 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclBasic.c: [Bug 3532959] Make sure the lifetime management
+ * generic/tclProc.c: of entries in the linePBodyPtr hash table can
+ * tests/proc.test: tolerate either order of teardown, interp first,
+ or Proc first.
+
2012-06-08 Don Porter <dgp@users.sourceforge.net>
* unix/configure.in: Update autogoo for gettimeofday().
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b38558a..0b02d0d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -1555,12 +1555,16 @@ DeleteInterpProc(
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
CmdFrame *cfPtr = Tcl_GetHashValue(hPtr);
+ Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr);
- if (cfPtr->type == TCL_LOCATION_SOURCE) {
- Tcl_DecrRefCount(cfPtr->data.eval.path);
+ procPtr->iPtr = NULL;
+ if (cfPtr) {
+ if (cfPtr->type == TCL_LOCATION_SOURCE) {
+ Tcl_DecrRefCount(cfPtr->data.eval.path);
+ }
+ ckfree(cfPtr->line);
+ ckfree(cfPtr);
}
- ckfree(cfPtr->line);
- ckfree(cfPtr);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(iPtr->linePBodyPtr);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index d008217..7b0af3a 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -2234,7 +2234,7 @@ TclProcCleanupProc(
* procbody structures created by tbcload.
*/
- if (!iPtr) {
+ if (iPtr == NULL) {
return;
}
@@ -2245,13 +2245,15 @@ TclProcCleanupProc(
cfPtr = Tcl_GetHashValue(hePtr);
- if (cfPtr->type == TCL_LOCATION_SOURCE) {
- Tcl_DecrRefCount(cfPtr->data.eval.path);
- cfPtr->data.eval.path = NULL;
+ if (cfPtr) {
+ if (cfPtr->type == TCL_LOCATION_SOURCE) {
+ Tcl_DecrRefCount(cfPtr->data.eval.path);
+ cfPtr->data.eval.path = NULL;
+ }
+ ckfree(cfPtr->line);
+ cfPtr->line = NULL;
+ ckfree(cfPtr);
}
- ckfree(cfPtr->line);
- cfPtr->line = NULL;
- ckfree(cfPtr);
Tcl_DeleteHashEntry(hePtr);
}
@@ -2483,7 +2485,8 @@ SetLambdaFromAny(
Interp *iPtr = (Interp *) interp;
const char *name;
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
- int objc, result;
+ int isNew, objc, result;
+ CmdFrame *cfPtr = NULL;
Proc *procPtr;
if (interp == NULL) {
@@ -2578,14 +2581,14 @@ SetLambdaFromAny(
if (contextPtr->line
&& (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
- int isNew, buf[2];
- CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
+ int buf[2];
/*
* Move from approximation (line of list cmd word) to actual
* location (line of 2nd list element).
*/
+ cfPtr = ckalloc(sizeof(CmdFrame));
TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL);
cfPtr->level = -1;
@@ -2601,9 +2604,6 @@ SetLambdaFromAny(
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
-
- Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr,
- procPtr, &isNew), cfPtr);
}
/*
@@ -2615,6 +2615,8 @@ SetLambdaFromAny(
}
TclStackFree(interp, contextPtr);
}
+ Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, procPtr,
+ &isNew), cfPtr);
/*
* Set the namespace for this lambda: given by objv[2] understood as a
diff --git a/tests/proc.test b/tests/proc.test
index ed3c4b6..e06720e 100644
--- a/tests/proc.test
+++ b/tests/proc.test
@@ -374,6 +374,15 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body {
} -cleanup {
namespace delete ugly
} -result 4
+
+test proc-7.4 {Proc struct outlives its interp: Bug 3532959} {
+ set lambda x
+ lappend lambda {set a 1}
+ interp create slave
+ slave eval [list apply $lambda foo]
+ interp delete slave
+ unset lambda
+} {}
# cleanup
catch {rename p ""}