Tcl Source Code

2012-06-11  Don Porter  <[email protected]>

	* 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  <[email protected]>

	* unix/configure.in:	Update autogoo for gettimeofday().
	* unix/tclUnixPort.h:	Thanks Joe English.
	* unix/configure:	autoconf 2.13

	* unix/tclUnixPort.h:	[Bug 3530533] Centralize #include <pthread.h>

	Tcl_HashSearch hSearch;
	int i;

	for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch);
		hPtr != NULL;
		hPtr = Tcl_NextHashEntry(&hSearch)) {
	    CmdFrame *cfPtr = Tcl_GetHashValue(hPtr);
	    Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr);
	    procPtr->iPtr = NULL;
	    if (cfPtr) {
		if (cfPtr->type == TCL_LOCATION_SOURCE) {
		    Tcl_DecrRefCount(cfPtr->data.eval.path);
		}
		ckfree((char *) cfPtr->line);
		ckfree((char *) cfPtr);
	    }
	    Tcl_DeleteHashEntry(hPtr);
	}
	Tcl_DeleteHashTable(iPtr->linePBodyPtr);
	ckfree((char *) iPtr->linePBodyPtr);
	iPtr->linePBodyPtr = NULL;

	/*

    /*
     * TIP #280: Release the location data associated with this Proc
     * structure, if any. The interpreter may not exist (For example for
     * procbody structures created by tbcload. See also Tcl_ProcObjCmd(), when
     * the same ProcPtr is overwritten with a new CmdFrame.
     */

    if (iPtr == NULL) {
	return;
    }

    hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
    if (!hePtr) {
	return;
    }

    cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr);

    if (cfPtr) {
	if (cfPtr->type == TCL_LOCATION_SOURCE) {
	    Tcl_DecrRefCount(cfPtr->data.eval.path);
	    cfPtr->data.eval.path = NULL;
	}
	ckfree((char *) cfPtr->line);
	cfPtr->line = NULL;
	ckfree((char *) cfPtr);
    }
    Tcl_DeleteHashEntry(hePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclUpdateReturnInfo --

SetLambdaFromAny(
    Tcl_Interp *interp,		/* Used for error reporting if not NULL. */
    register Tcl_Obj *objPtr)	/* The object to convert. */
{
    Interp *iPtr = (Interp *) interp;
    char *name;
    Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr;
    int isNew, objc, result;
    CmdFrame *cfPtr = NULL;
    Proc *procPtr;

    if (interp == NULL) {
	return TCL_ERROR;
    }

    /*

	    /*
	     * We can record source location within a lambda only if the body
	     * was not created by substitution.
	     */

	    if (contextPtr->line
		    && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
		int buf[2];


		/*
		 * Move from approximation (line of list cmd word) to actual
		 * location (line of 2nd list element).
		 */

		cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
		TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL);

		cfPtr->level = -1;
		cfPtr->type = contextPtr->type;
		cfPtr->line = (int *) ckalloc(sizeof(int));
		cfPtr->line[0] = buf[1];
		cfPtr->nline = 1;
		cfPtr->framePtr = NULL;
		cfPtr->nextPtr = NULL;

		cfPtr->data.eval.path = contextPtr->data.eval.path;
		Tcl_IncrRefCount(cfPtr->data.eval.path);

		cfPtr->cmd.str.cmd = NULL;
		cfPtr->cmd.str.len = 0;



	    }

	    /*
	     * 'contextPtr' is going out of scope. Release the reference that
	     * it's holding to the source file path
	     */

	    Tcl_DecrRefCount(contextPtr->data.eval.path);
	}
	TclStackFree(interp, contextPtr);
    }
    Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr,
	    &isNew), cfPtr);

    /*
     * Set the namespace for this lambda: given by objv[2] understood as a
     * global reference, or else global per default.
     */

    if (objc == 2) {

	return $i
    }
    set res [list [catch {ugly::foo} msg] $msg]
    namespace delete ugly
    set res
} {0 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 ""}
catch {rename t ""}
::tcltest::cleanupTests
return