Fix [28027d8bb7745fb0], memory leaks in tclUnload.c,

3 files changed, 91 insertions, 53 deletions

diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 514d3c8..3d64edb 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -96,11 +96,19 @@ typedef struct InterpLibrary {
 
 static void	LoadCleanupProc(ClientData clientData,
 		    Tcl_Interp *interp);
+static int	IsStatic (LoadedLibrary *libraryPtr);
 static int	UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target,
 		    LoadedLibrary *library, int keepLibrary,
-		    const char *fullFileName);
+		    const char *fullFileName, int interpExiting);
 
 
+static int
+IsStatic (LoadedLibrary *libraryPtr) {
+    int res;
+    res = (libraryPtr->fileName[0] == '\0');
+    return res;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -649,7 +657,7 @@ Tcl_UnloadObjCmd(
      *  - Its prefix and file match the once we're looking for.
      *  - Its file matches, and we weren't given a prefix.
      *  - Its prefix matches, the file name was specified as empty, and there is
-     *	  only no statically loaded library with the same prefix.
+     *	  no statically loaded library with the same prefix.
      */
 
     Tcl_MutexLock(&libraryMutex);
@@ -744,7 +752,7 @@ Tcl_UnloadObjCmd(
 	goto done;
     }
 
-    code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName);
+    code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName, 0);
 
   done:
     Tcl_DStringFree(&pfx);
@@ -762,14 +770,15 @@ UnloadLibrary(
 	Tcl_Interp *target,
 	LoadedLibrary *libraryPtr,
 	int keepLibrary,
-	const char *fullFileName
+	const char *fullFileName,
+	int interpExiting
 )
 {
     int code;
     InterpLibrary *ipFirstPtr, *ipPtr;
     LoadedLibrary *defaultPtr;
-    int trustedRefCount, safeRefCount;
-    Tcl_LibraryUnloadProc *unloadProc;
+    int trustedRefCount = -1, safeRefCount = -1;
+    Tcl_LibraryUnloadProc *unloadProc = NULL;
 
     /*
      * Ensure that the DLL can be unloaded. If it is a trusted interpreter,
@@ -779,31 +788,34 @@ UnloadLibrary(
 
     if (Tcl_IsSafe(target)) {
 	if (libraryPtr->safeUnloadProc == NULL) {
-	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		    "file \"%s\" cannot be unloaded under a safe interpreter",
-		    fullFileName));
-	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
-		    NULL);
-	    code = TCL_ERROR;
-	    goto done;
+	    if (!interpExiting) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"file \"%s\" cannot be unloaded under a safe interpreter",
+			fullFileName));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+			NULL);
+		code = TCL_ERROR;
+		goto done;
+	    }
 	}
 	unloadProc = libraryPtr->safeUnloadProc;
     } else {
 	if (libraryPtr->unloadProc == NULL) {
-	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		    "file \"%s\" cannot be unloaded under a trusted interpreter",
-		    fullFileName));
-	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
-		    NULL);
-	    code = TCL_ERROR;
-	    goto done;
+	    if (!interpExiting) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"file \"%s\" cannot be unloaded under a trusted interpreter",
+			fullFileName));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+			NULL);
+		code = TCL_ERROR;
+		goto done;
+	    }
 	}
 	unloadProc = libraryPtr->unloadProc;
     }
 
 
 
-
     /*
      * We are ready to unload the library. First, evaluate the unload
      * function. If this fails, we cannot proceed with unload. Also, we must
@@ -814,24 +826,30 @@ UnloadLibrary(
      * after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed.
      */
 
-    code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
-    if (!keepLibrary) {
-	Tcl_MutexLock(&libraryMutex);
-	trustedRefCount = libraryPtr->interpRefCount;
-	safeRefCount = libraryPtr->safeInterpRefCount;
-	Tcl_MutexUnlock(&libraryMutex);
+    if (unloadProc == NULL) {
+	code = TCL_OK;
+    } else {
+	code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
+	if (!keepLibrary) {
+	    Tcl_MutexLock(&libraryMutex);
+	    trustedRefCount = libraryPtr->interpRefCount;
+	    safeRefCount = libraryPtr->safeInterpRefCount;
+	    Tcl_MutexUnlock(&libraryMutex);
 
-	if (Tcl_IsSafe(target)) {
-	    safeRefCount--;
-	} else {
-	    trustedRefCount--;
-	}
+	    if (Tcl_IsSafe(target)) {
+		safeRefCount--;
+	    } else {
+		trustedRefCount--;
+	    }
 
-	if (safeRefCount <= 0 && trustedRefCount <= 0) {
-	    code = TCL_UNLOAD_DETACH_FROM_PROCESS;
+	    if (safeRefCount <= 0 && trustedRefCount <= 0) {
+		code = TCL_UNLOAD_DETACH_FROM_PROCESS;
+	    }
 	}
+	code = unloadProc(target, code);
     }
-    code = unloadProc(target, code);
+
+
     if (code != TCL_OK) {
 	Tcl_TransferResult(target, code, interp);
 	goto done;
@@ -857,16 +875,20 @@ UnloadLibrary(
 	    }
 	}
     }
-    Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
-	    ipFirstPtr);
+    ckfree(ipPtr);
+    Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr);
 
 
+    if (IsStatic(libraryPtr)) {
+	goto done;
+    }
 
     /*
      * The unload function executed fine. Examine the reference count to see
      * if we unload the DLL.
      */
 
+
     Tcl_MutexLock(&libraryMutex);
     if (Tcl_IsSafe(target)) {
 	libraryPtr->safeInterpRefCount--;
@@ -908,7 +930,7 @@ UnloadLibrary(
 	 * it's been unloaded.
 	 */
 
-	if (libraryPtr->fileName[0] != '\0') {
+	if (!IsStatic(libraryPtr)) {
 	    Tcl_MutexLock(&libraryMutex);
 	    if (Tcl_FSUnloadFile(interp, libraryPtr->loadHandle) == TCL_OK) {
 		/*
@@ -931,7 +953,6 @@ UnloadLibrary(
 		ckfree(defaultPtr->fileName);
 		ckfree(defaultPtr->prefix);
 		ckfree(defaultPtr);
-		ckfree(ipPtr);
 		Tcl_MutexUnlock(&libraryMutex);
 	    } else {
 		code = TCL_ERROR;
@@ -1020,6 +1041,8 @@ Tcl_StaticLibrary(
 	libraryPtr->loadHandle	= NULL;
 	libraryPtr->initProc	= initProc;
 	libraryPtr->safeInitProc	= safeInitProc;
+	libraryPtr->unloadProc = NULL;
+	libraryPtr->safeUnloadProc = NULL;
 	Tcl_MutexLock(&libraryMutex);
 	libraryPtr->nextPtr		= firstLibraryPtr;
 	firstLibraryPtr		= libraryPtr;
@@ -1170,15 +1193,18 @@ static void
 LoadCleanupProc(
     ClientData clientData,	/* Pointer to first InterpLibrary structure
 				 * for interp. */
-    TCL_UNUSED(Tcl_Interp *))
+    Tcl_Interp *interp)
 {
-    InterpLibrary *ipPtr, *nextPtr;
+    InterpLibrary *ipPtr;
+    LoadedLibrary *libraryPtr;
 
-    ipPtr = (InterpLibrary *)clientData;
-    while (ipPtr != NULL) {
-	nextPtr = ipPtr->nextPtr;
-	ckfree(ipPtr);
-	ipPtr = nextPtr;
+    while (1) {
+	ipPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL);
+	if (ipPtr == NULL) {
+	    break;
+	}
+	libraryPtr = ipPtr->libraryPtr;
+	UnloadLibrary(interp, interp, libraryPtr, 0 ,"", 1);
     }
 }
 
@@ -1223,7 +1249,7 @@ TclFinalizeLoad(void)
 	 * it has been unloaded.
 	 */
 
-	if (libraryPtr->fileName[0] != '\0') {
+	if (!IsStatic(libraryPtr)) {
 	    Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle);
 	}
 #endif
diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test
index df49c32..002efcc 100644
--- a/tests/pkgMkIndex.test
+++ b/tests/pkgMkIndex.test
@@ -577,19 +577,21 @@ test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] {
     exec [interpreter] << $cmd
     pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
 } "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
+
 test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
     # Do all [load]ing of shared libraries in another process, so we can
     # delete the file and not get stuck because we're holding a reference to
     # it.
     #
     # This test depends on context from prior test, so repeat it.
+	
     set script \
 	"[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]"
     append script \n \
 	"[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]"
     exec [interpreter] << $script
     pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension]
-} {0 {}}
+} {0 {{pkga:1.0 {tclPkgSetup {pkga.so load {pkga_eq pkga_quote}}}}}}
 
 if {[testConstraint $dll]} {
     file delete -force [file join $fullPkgPath [file tail $x]]
diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c
index 0ab3e23..7082b36 100644
--- a/unix/dltest/pkgua.c
+++ b/unix/dltest/pkgua.c
@@ -21,6 +21,7 @@ static int    PkguaEqObjCmd(ClientData clientData,
 		Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
 static int    PkguaQuoteObjCmd(ClientData clientData,
 		Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+static void    CommandDeleted(ClientData clientData);
 
 /*
  * In the following hash table we are going to store a struct that holds all
@@ -40,6 +41,13 @@ static int interpTokenMapInitialised = 0;
 
 
 static void
+CommandDeleted(ClientData clientData)
+{
+    Tcl_Command *cmdToken = clientData;
+    *cmdToken = NULL;
+}
+
+static void
 PkguaInitTokensHashTable(void)
 {
     if (interpTokenMapInitialised) {
@@ -221,12 +229,14 @@ Pkgua_Init(
     Tcl_SetVar2(interp, "::pkgua_loaded", NULL, ".", TCL_APPEND_VALUE);
 
     cmdTokens = PkguaInterpToTokens(interp);
-    cmdTokens[cmdIndex++] =
-	    Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, NULL,
-		    NULL);
-    cmdTokens[cmdIndex++] =
+    cmdTokens[cmdIndex] =
+	    Tcl_CreateObjCommand(interp, "pkgua_eq", PkguaEqObjCmd, &cmdTokens[cmdIndex],
+		    CommandDeleted);
+    cmdIndex++;
+    cmdTokens[cmdIndex] =
 	    Tcl_CreateObjCommand(interp, "pkgua_quote", PkguaQuoteObjCmd,
-		    NULL, NULL);
+		    &cmdTokens[cmdIndex], CommandDeleted);
+    cmdIndex++;
     return TCL_OK;
 }