[Bug 2919042] Restore "valgrindability" of Tcl that was lost by the streamlining of [exit], by conditionally forcing a full Finalize: use -DPURIFY or ::env(TCL_FINALIZE_ON_EXIT)

1 files changed, 72 insertions, 15 deletions

diff --git a/generic/tclMain.c b/generic/tclMain.c
index 26383b5..c7166d7 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -125,6 +125,7 @@ typedef struct InteractiveState {
 MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void);
 static void		Prompt(Tcl_Interp *interp, InteractiveState *isPtr);
 static void		StdinProc(ClientData clientData, int mask);
+static void     FreeMainInterp(ClientData clientData);
 
 #ifndef TCL_ASCII_MAIN
 static Tcl_ThreadDataKey dataKey;
@@ -387,6 +388,13 @@ Tcl_MainEx(
     if (Tcl_LimitExceeded(interp)) {
 	goto done;
     }
+    if (TclFullFinalizationRequested()) {
+	/*
+	 * Arrange for final deletion of the main interp
+	 */
+	// ARGH Munchhausen effect 
+	Tcl_CreateExitHandler(FreeMainInterp, (ClientData)interp);
+    }
 
     /*
      * Invoke the script specified on the command line, if any. Must fetch it
@@ -597,31 +605,18 @@ Tcl_MainEx(
     if (!Tcl_InterpDeleted(interp)) {
 	if (!Tcl_LimitExceeded(interp)) {
 	    Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
-
+	    
 	    Tcl_IncrRefCount(cmd);
 	    Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
 	    Tcl_DecrRefCount(cmd);
 	}
-
+    }
 	/*
 	 * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
 	 * is happening. Maybe interp has been deleted; maybe [exit] was
 	 * redefined, maybe we've blown up because of an exceeded limit. We
 	 * still want to cleanup and exit.
 	 */
-
-	if (!Tcl_InterpDeleted(interp)) {
-	    Tcl_DeleteInterp(interp);
-	}
-    }
-    Tcl_SetStartupScript(NULL, NULL);
-
-    /*
-     * If we get here, the master interp has been deleted. Allow its
-     * destruction with the last matching Tcl_Release.
-     */
-
-    Tcl_Release(interp);
     Tcl_Exit(exitCode);
 }
 
@@ -699,6 +694,42 @@ TclGetMainLoop(void)
 /*
  *----------------------------------------------------------------------
  *
+ * TclFullFinalizationRequested --
+ *
+ *	This function returns true when either -DPURIFY is specified, or the
+ *	environment variable TCL_FINALIZE_ON_EXIT is set and not "0". This
+ *	predicate is called at places affecting the exit sequence, so that the
+ *	default behavior is a fast and deadlock-free exit, and the modified
+ *	behavior is a more thorough finalization for debugging purposes (leak
+ *	hunting etc).
+ *
+ * Results:
+ *	A boolean.
+ *
+ *----------------------------------------------------------------------
+ */
+MODULE_SCOPE int
+TclFullFinalizationRequested(void)
+{
+#ifdef PURIFY
+    return 1;
+#else
+    const char *fin;
+    Tcl_DString ds;
+    int finalize = 0;
+    
+    fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds);
+    finalize = ((fin != NULL) && strcmp(fin, "0"));
+    if (fin != NULL) {
+	Tcl_DStringFree(&ds);
+    }
+    return finalize;
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * StdinProc --
  *
  *	This function is invoked by the event dispatcher whenever standard
@@ -881,6 +912,32 @@ Prompt(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * FreeMainInterp --
+ *
+ *	Exit handler used to cleanup the main interpreter and ancillary startup
+ *	script storage at exit.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeMainInterp(
+    ClientData clientData)
+{
+	Tcl_Interp *interp = (Tcl_Interp *) clientData;
+
+	//if (TclInExit()) return;
+
+	if (!Tcl_InterpDeleted(interp)) {
+	    Tcl_DeleteInterp(interp);
+	}
+    Tcl_SetStartupScript(NULL, NULL);
+    Tcl_Release(interp);
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4