diff options
author | dkf <dkf@noemail.net> | 2004-02-24 22:58:27 (GMT) |
---|---|---|
committer | dkf <dkf@noemail.net> | 2004-02-24 22:58:27 (GMT) |
commit | 3ea0f8ca6631402b1d625ad70522b2d459e004ef (patch) | |
tree | 28f7d836fd11991bcc636e6b4b31626abc424381 /generic/tclLoad.c | |
parent | 0860ee74056aa4ce495ab3b97b5ac6eea7d048c7 (diff) | |
download | tcl-3ea0f8ca6631402b1d625ad70522b2d459e004ef.zip tcl-3ea0f8ca6631402b1d625ad70522b2d459e004ef.tar.gz tcl-3ea0f8ca6631402b1d625ad70522b2d459e004ef.tar.bz2 |
TIP#100 implementation largely based on work by Georgios Petasis.
FossilOrigin-Name: 4f599936a4b736fee3af0ec8d022cb5172a26050
Diffstat (limited to 'generic/tclLoad.c')
-rw-r--r-- | generic/tclLoad.c | 505 |
1 files changed, 490 insertions, 15 deletions
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 |