summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2004-02-24 22:58:28 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2004-02-24 22:58:28 (GMT)
commit0575111723f30910c2e2362a7dba2853c95c6969 (patch)
tree28f7d836fd11991bcc636e6b4b31626abc424381 /generic
parent6842d4e8779d8ccdfd67170215cef172e9474e9e (diff)
downloadtcl-0575111723f30910c2e2362a7dba2853c95c6969.zip
tcl-0575111723f30910c2e2362a7dba2853c95c6969.tar.gz
tcl-0575111723f30910c2e2362a7dba2853c95c6969.tar.bz2
TIP#100 implementation largely based on work by Georgios Petasis.
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.h9
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclLoad.c505
4 files changed, 504 insertions, 18 deletions
diff --git a/generic/tcl.h b/generic/tcl.h
index 83ad1bd..e53fcf0 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tcl.h,v 1.170 2004/01/09 20:55:26 davygrvy Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.171 2004/02/24 22:58:45 dkf Exp $
*/
#ifndef _TCL
@@ -697,6 +697,8 @@ typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST * objv));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
+typedef int (Tcl_PackageUnloadProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ int flags));
typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(CONST char *, format));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
Tcl_Channel chan, char *address, int port));
@@ -1627,6 +1629,11 @@ typedef struct Tcl_GlobTypeData {
#define TCL_GLOB_PERM_W (1<<3)
#define TCL_GLOB_PERM_X (1<<4)
+/*
+ * Flags for the unload callback procedure
+ */
+#define TCL_UNLOAD_DETACH_FROM_INTERPRETER (1<<0)
+#define TCL_UNLOAD_DETACH_FROM_PROCESS (1<<1)
/*
* Typedefs for the various filesystem operations:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 2334d53..7c5e460 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.96 2004/01/18 16:19:04 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.97 2004/02/24 22:58:46 dkf Exp $
*/
#include "tclInt.h"
@@ -166,6 +166,8 @@ static CmdInfo builtInCmds[] = {
TclCompileSwitchCmd, 1},
{"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd,
(CompileProc *) NULL, 1},
+ {"unload", (Tcl_CmdProc *) NULL, Tcl_UnloadObjCmd,
+ (CompileProc *) NULL, 1},
{"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd,
(CompileProc *) NULL, 1},
{"uplevel", (Tcl_CmdProc *) NULL, Tcl_UplevelObjCmd,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6825d08..27dbc89 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.143 2004/01/21 19:59:33 vincentdarley Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.144 2004/02/24 22:58:46 dkf Exp $
*/
#ifndef _TCLINT
@@ -2005,6 +2005,8 @@ EXTERN int Tcl_TimeObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_TraceObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_UnloadObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_UnsetObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_UpdateObjCmd _ANSI_ARGS_((ClientData clientData,
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 2227e6e..5be526c 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLoad.c,v 1.10 2004/02/21 12:48:50 dkf Exp $
+ * RCS: @(#) $Id: tclLoad.c,v 1.11 2004/02/24 22:58:48 dkf Exp $
*/
#include "tclInt.h"
@@ -47,6 +47,18 @@ typedef struct LoadedPackage {
* untrusted scripts). NULL means the
* package can't be used in unsafe
* interpreters. */
+ Tcl_PackageUnloadProc *unloadProc;
+ /* Finalisation procedure to unload a package
+ * from a trusted interpreter. NULL means
+ * that the package cannot be unloaded. */
+ Tcl_PackageUnloadProc *safeUnloadProc;
+ /* Finalisation procedure to unload a package
+ * from a safe interpreter. NULL means
+ * that the package cannot be unloaded. */
+ int interpRefCount; /* How many times the package has been loaded
+ in trusted interpreters. */
+ int safeInterpRefCount; /* How many times the package has been loaded
+ in safe interpreters. */
Tcl_FSUnloadFileProc *unLoadProcPtr;
/* Procedure to use to unload this package.
* If NULL, then we do not attempt to unload
@@ -119,10 +131,14 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
{
Tcl_Interp *target;
LoadedPackage *pkgPtr, *defaultPtr;
- Tcl_DString pkgName, tmp, initName, safeInitName;
- Tcl_PackageInitProc *initProc, *safeInitProc;
+ Tcl_DString pkgName, tmp, initName, safeInitName,
+ unloadName, safeUnloadName;
+ Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc;
InterpPackage *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch;
+ CONST char *symbols[4];
+ Tcl_PackageInitProc **procPtrs[4];
+ ClientData clientData;
char *p, *fullFileName, *packageName;
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
@@ -141,6 +157,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
Tcl_DStringInit(&pkgName);
Tcl_DStringInit(&initName);
Tcl_DStringInit(&safeInitName);
+ Tcl_DStringInit(&unloadName);
+ Tcl_DStringInit(&safeUnloadName);
Tcl_DStringInit(&tmp);
packageName = NULL;
@@ -332,21 +350,33 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
Tcl_DStringAppend(&initName, "_Init", 5);
Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
+ Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1);
+ Tcl_DStringAppend(&unloadName, "_Unload", 7);
+ Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1);
+ Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11);
/*
* Call platform-specific code to load the package and find the
* two initialization procedures.
*/
+ symbols[0] = Tcl_DStringValue(&initName);
+ symbols[1] = Tcl_DStringValue(&safeInitName);
+ symbols[2] = Tcl_DStringValue(&unloadName);
+ symbols[3] = Tcl_DStringValue(&safeUnloadName);
+ procPtrs[0] = &initProc;
+ procPtrs[1] = &safeInitProc;
+ procPtrs[2] = &unloadProc;
+ procPtrs[3] = &safeUnloadProc;
Tcl_MutexLock(&packageMutex);
- code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName),
- Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
- &loadHandle,&unLoadProcPtr);
+ code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs,
+ &loadHandle, &clientData, &unLoadProcPtr);
Tcl_MutexUnlock(&packageMutex);
+ loadHandle = (Tcl_LoadHandle) clientData;
if (code != TCL_OK) {
goto done;
}
- if (initProc == NULL) {
+ if (procPtrs[0] /* initProc */ == NULL) {
Tcl_AppendResult(interp, "couldn't find procedure ",
Tcl_DStringValue(&initName), (char *) NULL);
if (unLoadProcPtr != NULL) {
@@ -361,19 +391,23 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
*/
pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
- pkgPtr->fileName = (char *) ckalloc((unsigned)
+ pkgPtr->fileName = (char *) ckalloc((unsigned)
(strlen(fullFileName) + 1));
strcpy(pkgPtr->fileName, fullFileName);
- pkgPtr->packageName = (char *) ckalloc((unsigned)
+ pkgPtr->packageName = (char *) ckalloc((unsigned)
(Tcl_DStringLength(&pkgName) + 1));
strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
- pkgPtr->loadHandle = loadHandle;
- pkgPtr->unLoadProcPtr = unLoadProcPtr;
- pkgPtr->initProc = initProc;
- pkgPtr->safeInitProc = safeInitProc;
+ pkgPtr->loadHandle = loadHandle;
+ pkgPtr->unLoadProcPtr = unLoadProcPtr;
+ pkgPtr->initProc = *procPtrs[0];
+ pkgPtr->safeInitProc = *procPtrs[1];
+ pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2];
+ pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3];
+ pkgPtr->interpRefCount = 0;
+ pkgPtr->safeInterpRefCount = 0;
Tcl_MutexLock(&packageMutex);
- pkgPtr->nextPtr = firstPackagePtr;
- firstPackagePtr = pkgPtr;
+ pkgPtr->nextPtr = firstPackagePtr;
+ firstPackagePtr = pkgPtr;
Tcl_MutexUnlock(&packageMutex);
}
@@ -404,6 +438,16 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
*/
if (code == TCL_OK) {
+ /*
+ * Update the proper reference count.
+ */
+ Tcl_MutexLock(&packageMutex);
+ if (Tcl_IsSafe(target)) {
+ ++pkgPtr->safeInterpRefCount;
+ } else {
+ ++pkgPtr->interpRefCount;
+ }
+ Tcl_MutexUnlock(&packageMutex);
/*
* Refetch ipFirstPtr: loading the package may have introduced
* additional static packages at the head of the linked list!
@@ -424,6 +468,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
Tcl_DStringFree(&pkgName);
Tcl_DStringFree(&initName);
Tcl_DStringFree(&safeInitName);
+ Tcl_DStringFree(&unloadName);
+ Tcl_DStringFree(&safeUnloadName);
Tcl_DStringFree(&tmp);
return code;
}
@@ -431,6 +477,435 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * Tcl_UnloadObjCmd --
+ *
+ * This procedure is invoked to process the "unload" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UnloadObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Tcl_Interp *target; /* Which interpreter to unload from. */
+ LoadedPackage *pkgPtr;
+ LoadedPackage *defaultPtr;
+ Tcl_DString pkgName;
+ Tcl_DString tmp;
+ Tcl_PackageUnloadProc *unloadProc;
+ InterpPackage *ipFirstPtr;
+ InterpPackage *ipPtr;
+ int i;
+ int index;
+ int code;
+ int complain = 1;
+ int keepLibrary = 0;
+ int trustedRefCount = -1;
+ int safeRefCount = -1;
+ char *fullFileName = "";
+ char *packageName;
+ static CONST char *options[] = {
+ "-nocomplain", "-keeplibrary", "--", NULL
+ };
+ enum options {
+ UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST
+ };
+
+ for (i = 1; i < objc; i++) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &index) != TCL_OK) {
+ fullFileName = Tcl_GetString(objv[i]);
+ if (fullFileName[0] == '-') {
+ /*
+ * It looks like the command contains an option so signal
+ * an error
+ */
+
+ return TCL_ERROR;
+ } else {
+ /*
+ * This clearly isn't an option; assume it's the
+ * filename. We must clear the error.
+ */
+
+ Tcl_ResetResult(interp);
+ break;
+ }
+ }
+ switch (index) {
+ case UNLOAD_NOCOMPLAIN: /* -nocomplain */
+ complain = 0;
+ break;
+ case UNLOAD_KEEPLIB: /* -keeplibrary */
+ keepLibrary = 1;
+ break;
+ case UNLOAD_LAST: /* -- */
+ i++;
+ goto endOfForLoop;
+ }
+ }
+ endOfForLoop:
+ if ((objc-i < 1) || (objc-i > 3)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?switches? fileName ?packageName? ?interp?");
+ return TCL_ERROR;
+ }
+ if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ fullFileName = Tcl_GetString(objv[i]);
+ Tcl_DStringInit(&pkgName);
+ Tcl_DStringInit(&tmp);
+
+ packageName = NULL;
+ if (objc - i >= 2) {
+ packageName = Tcl_GetString(objv[i+1]);
+ if (packageName[0] == '\0') {
+ packageName = NULL;
+ }
+ }
+ if ((fullFileName[0] == 0) && (packageName == NULL)) {
+ Tcl_SetResult(interp,
+ "must specify either file name or package name",
+ TCL_STATIC);
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Figure out which interpreter we're going to load the package into.
+ */
+
+ target = interp;
+ if (objc - i == 3) {
+ char *slaveIntName;
+ slaveIntName = Tcl_GetString(objv[i+2]);
+ target = Tcl_GetSlave(interp, slaveIntName);
+ if (target == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Scan through the packages that are currently loaded to see if the
+ * package we want is already loaded. We'll use a loaded package if
+ * it meets any of the following conditions:
+ * - Its name and file match the once we're looking for.
+ * - Its file matches, and we weren't given a name.
+ * - Its name matches, the file name was specified as empty, and there
+ * is only no statically loaded package with the same name.
+ */
+
+ Tcl_MutexLock(&packageMutex);
+
+ defaultPtr = NULL;
+ for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
+ int namesMatch, filesMatch;
+
+ if (packageName == NULL) {
+ namesMatch = 0;
+ } else {
+ Tcl_DStringSetLength(&pkgName, 0);
+ Tcl_DStringAppend(&pkgName, packageName, -1);
+ Tcl_DStringSetLength(&tmp, 0);
+ Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
+ Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
+ Tcl_UtfToLower(Tcl_DStringValue(&tmp));
+ if (strcmp(Tcl_DStringValue(&tmp),
+ Tcl_DStringValue(&pkgName)) == 0) {
+ namesMatch = 1;
+ } else {
+ namesMatch = 0;
+ }
+ }
+ Tcl_DStringSetLength(&pkgName, 0);
+
+ filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
+ if (filesMatch && (namesMatch || (packageName == NULL))) {
+ break;
+ }
+ if (namesMatch && (fullFileName[0] == 0)) {
+ defaultPtr = pkgPtr;
+ }
+ if (filesMatch && !namesMatch && (fullFileName[0] != 0)) {
+ break;
+ }
+ }
+ Tcl_MutexUnlock(&packageMutex);
+ if (fullFileName[0] == 0) {
+ /*
+ * It's an error to try unload a static package.
+ */
+
+ Tcl_AppendResult(interp, "package \"", packageName,
+ "\" is loaded statically and cannot be unloaded",
+ (char *) NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
+ if (pkgPtr == NULL) {
+ /*
+ * The DLL pointed by the provided filename has never been
+ * loaded.
+ */
+
+ Tcl_AppendResult(interp, "file \"", fullFileName,
+ "\" has never been loaded", (char *) NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Scan through the list of packages already loaded in the target
+ * interpreter. If the package we want is already loaded there,
+ * then we should proceed with unloading.
+ */
+
+ code = TCL_ERROR;
+ if (pkgPtr != NULL) {
+ ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
+ (Tcl_InterpDeleteProc **) NULL);
+ for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+ if (ipPtr->pkgPtr == pkgPtr) {
+ code = TCL_OK;
+ break;
+ }
+ }
+ }
+ if (code != TCL_OK) {
+ /*
+ * The package has not been loaded in this interpreter.
+ */
+ Tcl_AppendResult(interp, "file \"", fullFileName,
+ "\" has never been loaded in this interpreter", (char *) NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Ensure that the DLL can be unloaded. If it is a trusted
+ * interpreter, pkgPtr->unloadProc must not be NULL for the DLL to
+ * be unloadable. If the interpreter is a safe one,
+ * pkgPtr->safeUnloadProc must be non-NULL.
+ */
+
+ if (Tcl_IsSafe(target)) {
+ if (pkgPtr->safeUnloadProc == NULL) {
+ Tcl_AppendResult(interp, "file \"", fullFileName,
+ "\" cannot be unloaded under a safe interpreter",
+ (char *) NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
+ unloadProc = pkgPtr->safeUnloadProc;
+ } else {
+ if (pkgPtr->unloadProc == NULL) {
+ Tcl_AppendResult(interp, "file \"", fullFileName,
+ "\" cannot be unloaded under a trusted interpreter",
+ (char *) NULL);
+ code = TCL_ERROR;
+ goto done;
+ }
+ unloadProc = pkgPtr->unloadProc;
+ }
+
+ /*
+ * We are ready to unload the package. First, evaluate the unload
+ * procedure. If this fails, we cannot proceed with unload. Also,
+ * we must specify the proper flag to pass to the unload callback.
+ * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback
+ * should only remove itself from the interpreter; the library
+ * will be unloaded in a future call of unload. In case the
+ * library will be unloaded just after the callback returns,
+ * TCL_UNLOAD_DETACH_FROM_PROCESS is passed.
+ */
+
+ code = TCL_UNLOAD_DETACH_FROM_INTERPRETER;
+ if (!keepLibrary) {
+ Tcl_MutexLock(&packageMutex);
+ trustedRefCount = pkgPtr->interpRefCount;
+ safeRefCount = pkgPtr->safeInterpRefCount;
+ Tcl_MutexUnlock(&packageMutex);
+
+ if (Tcl_IsSafe(target)) {
+ --safeRefCount;
+ } else {
+ --trustedRefCount;
+ }
+
+ if (safeRefCount <= 0 && trustedRefCount <= 0) {
+ code = TCL_UNLOAD_DETACH_FROM_PROCESS;
+ }
+ }
+ code = (*unloadProc)(target, code);
+ if (code != TCL_OK) {
+ TclTransferResult(target, code, interp);
+ goto done;
+ }
+
+ /*
+ * The unload procedure executed fine. Examine the reference
+ * count to see if we unload the DLL.
+ */
+
+ Tcl_MutexLock(&packageMutex);
+ if (Tcl_IsSafe(target)) {
+ --pkgPtr->safeInterpRefCount;
+ /*
+ * Do not let counter get negative
+ */
+ if (pkgPtr->safeInterpRefCount < 0) {
+ pkgPtr->safeInterpRefCount = 0;
+ }
+ } else {
+ --pkgPtr->interpRefCount;
+ /*
+ * Do not let counter get negative
+ */
+ if (pkgPtr->interpRefCount < 0) {
+ pkgPtr->interpRefCount = 0;
+ }
+ }
+ trustedRefCount = pkgPtr->interpRefCount;
+ safeRefCount = pkgPtr->safeInterpRefCount;
+ Tcl_MutexUnlock(&packageMutex);
+
+ code = TCL_OK;
+ if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0
+ && !keepLibrary) {
+ /*
+ * Unload the shared library from the application memory...
+ */
+
+#if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__)
+ /*
+ * Some Unix dlls are poorly behaved - registering things like
+ * atexit calls that can't be unregistered. If you unload
+ * such dlls, you get a core on exit because it wants to call
+ * a function in the dll after it's been unloaded.
+ */
+
+ if (pkgPtr->fileName[0] != '\0') {
+ Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
+
+ if (unLoadProcPtr != NULL) {
+ Tcl_MutexLock(&packageMutex);
+ (*unLoadProcPtr)(pkgPtr->loadHandle);
+
+ /*
+ * Remove this library from the loaded library cache.
+ */
+
+ defaultPtr = pkgPtr;
+ if (defaultPtr == firstPackagePtr) {
+ firstPackagePtr = pkgPtr->nextPtr;
+ } else {
+ for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
+ pkgPtr = pkgPtr->nextPtr) {
+ if (pkgPtr->nextPtr == defaultPtr) {
+ pkgPtr->nextPtr = defaultPtr->nextPtr;
+ break;
+ }
+ }
+ }
+
+ /*
+ * Remove this library from the interpreter's library
+ * cache.
+ */
+
+ ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target,
+ "tclLoad", (Tcl_InterpDeleteProc **) NULL);
+ ipPtr = ipFirstPtr;
+ if (ipPtr->pkgPtr == defaultPtr) {
+ ipFirstPtr = ipFirstPtr->nextPtr;
+ } else {
+ InterpPackage *ipPrevPtr;
+
+ for (ipPrevPtr = ipPtr; ipPtr != NULL;
+ ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) {
+ if (ipPtr->pkgPtr == pkgPtr) {
+ ipPrevPtr->nextPtr = ipPtr->nextPtr;
+ break;
+ }
+ }
+ }
+ Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
+ (ClientData) ipFirstPtr);
+ ckfree(defaultPtr->fileName);
+ ckfree(defaultPtr->packageName);
+ ckfree((char *) defaultPtr);
+ ckfree((char *) ipPtr);
+ Tcl_MutexUnlock(&packageMutex);
+ } else {
+ Tcl_AppendResult(interp, "file \"", fullFileName,
+ "\" cannot be unloaded: filesystem does not support unloading",
+ (char *) NULL);
+ code = TCL_ERROR;
+ }
+ }
+#else
+ Tcl_AppendResult(interp, "file \"", fullFileName,
+ "\" cannot be unloaded: unloading disabled", (char *) NULL);
+ code = TCL_ERROR;
+#endif
+ }
+
+ done:
+ Tcl_DStringFree(&pkgName);
+ Tcl_DStringFree(&tmp);
+ if (!complain && code!=TCL_OK) {
+ code = TCL_OK;
+ Tcl_ResetResult(interp);
+ }
+ if (code == TCL_OK) {
+#if 0
+ /*
+ * Result of [unload] was not documented in TIP#100, so force
+ * to be the empty string by commenting this out. DKF.
+ */
+
+ Tcl_Obj *resultObjPtr, *objPtr[2];
+
+ /*
+ * Our result is the two reference counts.
+ */
+
+ objPtr[0] = Tcl_NewIntObj(trustedRefCount);
+ objPtr[1] = Tcl_NewIntObj(safeRefCount);
+ if (objPtr[0] == NULL || objPtr[1] == NULL) {
+ if (objPtr[0]) {
+ Tcl_DecrRefCount(objPtr[0]);
+ }
+ if (objPtr[1]) {
+ Tcl_DecrRefCount(objPtr[1]);
+ }
+ } else {
+ resultObjPtr = Tcl_NewListObj(2, objPtr);
+ if (resultObjPtr != NULL) {
+ Tcl_SetObjResult(interp, resultObjPtr);
+ }
+ }
+#endif
+ }
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_StaticPackage --
*
* This procedure is invoked to indicate that a particular