diff options
Diffstat (limited to 'generic/tclLoad.c')
| -rw-r--r-- | generic/tclLoad.c | 839 |
1 files changed, 658 insertions, 181 deletions
diff --git a/generic/tclLoad.c b/generic/tclLoad.c index b576daf..e64d0e0 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -1,59 +1,69 @@ -/* +/* * tclLoad.c -- * - * This file provides the generic portion (those that are the same - * on all platforms) of Tcl's dynamic loading facilities. + * This file provides the generic portion (those that are the same on all + * platforms) of Tcl's dynamic loading facilities. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* - * The following structure describes a package that has been loaded - * either dynamically (with the "load" command) or statically (as - * indicated by a call to TclGetLoadedPackages). All such packages - * are linked together into a single list for the process. Packages - * are never unloaded, until the application exits, when - * TclFinalizeLoad is called, and these structures are freed. + * The following structure describes a package that has been loaded either + * dynamically (with the "load" command) or statically (as indicated by a call + * to TclGetLoadedPackages). All such packages are linked together into a + * single list for the process. Packages are never unloaded, until the + * application exits, when TclFinalizeLoad is called, and these structures are + * freed. */ typedef struct LoadedPackage { - char *fileName; /* Name of the file from which the - * package was loaded. An empty string - * means the package is loaded statically. - * Malloc-ed. */ + char *fileName; /* Name of the file from which the package was + * loaded. An empty string means the package + * is loaded statically. Malloc-ed. */ char *packageName; /* Name of package prefix for the package, * properly capitalized (first letter UC, - * others LC), no "_", as in "Net". + * others LC), no "_", as in "Net". * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file - * is no longer needed. If fileName is NULL, + * is no longer needed. If fileName is NULL, * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; - /* Initialization procedure to call to + /* Initialization function to call to * incorporate this package into a trusted * interpreter. */ Tcl_PackageInitProc *safeInitProc; - /* Initialization procedure to call to + /* Initialization function to call to * incorporate this package into a safe * interpreter (one that will execute - * untrusted scripts). NULL means the - * package can't be used in unsafe - * interpreters. */ + * untrusted scripts). NULL means the package + * can't be used in unsafe interpreters. */ + Tcl_PackageUnloadProc *unloadProc; + /* Finalisation function to unload a package + * from a trusted interpreter. NULL means that + * the package cannot be unloaded. */ + Tcl_PackageUnloadProc *safeUnloadProc; + /* Finalisation function 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 - * the package. If fileName is NULL, then - * this field is irrelevant. */ + /* Function to use to unload this package. If + * NULL, then we do not attempt to unload the + * package. If fileName is NULL, then this + * field is irrelevant. */ struct LoadedPackage *nextPtr; /* Next in list of all packages loaded into - * this application process. NULL means - * end of list. */ + * this application process. NULL means end of + * list. */ } LoadedPackage; /* @@ -69,35 +79,35 @@ static LoadedPackage *firstPackagePtr = NULL; TCL_DECLARE_MUTEX(packageMutex) /* - * The following structure represents a particular package that has - * been incorporated into a particular interpreter (by calling its - * initialization procedure). There is a list of these structures for - * each interpreter, with an AssocData value (key "load") for the - * interpreter that points to the first package (if any). + * The following structure represents a particular package that has been + * incorporated into a particular interpreter (by calling its initialization + * function). There is a list of these structures for each interpreter, with + * an AssocData value (key "load") for the interpreter that points to the + * first package (if any). */ typedef struct InterpPackage { LoadedPackage *pkgPtr; /* Points to detailed information about * package. */ struct InterpPackage *nextPtr; - /* Next package in this interpreter, or - * NULL for end of list. */ + /* Next package in this interpreter, or NULL + * for end of list. */ } InterpPackage; /* - * Prototypes for procedures that are private to this file: + * Prototypes for functions that are private to this file: */ -static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp)); +static void LoadCleanupProc(ClientData clientData, + Tcl_Interp *interp); /* *---------------------------------------------------------------------- * * Tcl_LoadObjCmd -- * - * This procedure is invoked to process the "load" Tcl command. - * See the user documentation for details on what it does. + * This function is invoked to process the "load" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -109,36 +119,41 @@ static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, */ int -Tcl_LoadObjCmd(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_LoadObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; Tcl_DString pkgName, tmp, initName, safeInitName; - Tcl_PackageInitProc *initProc, *safeInitProc; + Tcl_DString unloadName, safeUnloadName; + Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc; InterpPackage *ipFirstPtr, *ipPtr; - int code, namesMatch, filesMatch; + int code, namesMatch, filesMatch, offset; + const char *symbols[4]; + Tcl_PackageInitProc **procPtrs[4]; + ClientData clientData; char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; Tcl_UniChar ch; - int offset; if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } fullFileName = Tcl_GetString(objv[1]); - + Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); + Tcl_DStringInit(&unloadName); + Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); packageName = NULL; @@ -162,23 +177,25 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) target = interp; if (objc == 4) { - char *slaveIntName; - slaveIntName = Tcl_GetString(objv[3]); + char *slaveIntName = Tcl_GetString(objv[3]); + target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { - return TCL_ERROR; + code = TCL_ERROR; + goto done; } } /* * 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: + * 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. + * - 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; @@ -210,13 +227,12 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* - * Can't have two different packages loaded from the same - * file. + * Can't have two different packages loaded from the same file. */ Tcl_AppendResult(interp, "file \"", fullFileName, "\" is already loaded for package \"", - pkgPtr->packageName, "\"", (char *) NULL); + pkgPtr->packageName, "\"", NULL); code = TCL_ERROR; Tcl_MutexUnlock(&packageMutex); goto done; @@ -229,13 +245,13 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) /* * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, - * then there's nothing for us to to. + * interpreter. If the package we want is already loaded there, then + * there's nothing for us to do. */ if (pkgPtr != NULL) { - ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", - (Tcl_InterpDeleteProc **) NULL); + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, + "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->pkgPtr == pkgPtr) { code = TCL_OK; @@ -246,13 +262,13 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) if (pkgPtr == NULL) { /* - * The desired file isn't currently loaded, so load it. It's an - * error if the desired package is a static one. + * The desired file isn't currently loaded, so load it. It's an error + * if the desired package is a static one. */ if (fullFileName[0] == 0) { Tcl_AppendResult(interp, "package \"", packageName, - "\" isn't loaded statically", (char *) NULL); + "\" isn't loaded statically", NULL); code = TCL_ERROR; goto done; } @@ -265,9 +281,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_DStringAppend(&pkgName, packageName, -1); } else { int retc; + /* * Threading note - this call used to be protected by a mutex. */ + retc = TclGuessPackageName(fullFileName, &pkgName); if (!retc) { Tcl_Obj *splitPtr; @@ -276,11 +294,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) char *pkgGuess; /* - * The platform-specific code couldn't figure out the - * module name. Make a guess by taking the last element - * of the file name, stripping off any leading "lib", - * and then using all of the alphabetic and underline - * characters that follow that. + * The platform-specific code couldn't figure out the module + * name. Make a guess by taking the last element of the file + * name, stripping off any leading "lib", and then using all + * of the alphabetic and underline characters that follow + * that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); @@ -302,7 +320,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_DecrRefCount(splitPtr); Tcl_AppendResult(interp, "couldn't figure out package name for ", - fullFileName, (char *) NULL); + fullFileName, NULL); code = TCL_ERROR; goto done; } @@ -316,36 +334,50 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) * character is in caps (or title case) but the others are all * lower-case. */ - + Tcl_DStringSetLength(&pkgName, Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); /* - * Compute the names of the two initialization procedures, - * based on the package name. + * Compute the names of the two initialization functions, based on the + * package name. */ - + Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); 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. + * Call platform-specific code to load the package and find the two + * initialization functions. */ + 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); + Tcl_DStringValue(&initName), NULL); if (unLoadProcPtr != NULL) { (*unLoadProcPtr)(loadHandle); } @@ -358,26 +390,30 @@ 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); } /* - * Invoke the package's initialization procedure (either the - * normal one or the safe one, depending on whether or not the - * interpreter is safe). + * Invoke the package's initialization function (either the normal one or + * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { @@ -385,9 +421,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) code = (*pkgPtr->safeInitProc)(target); } else { Tcl_AppendResult(interp, - "can't use package in a safe interpreter: ", - "no ", pkgPtr->packageName, "_SafeInit procedure", - (char *) NULL); + "can't use package in a safe interpreter: no ", + pkgPtr->packageName, "_SafeInit procedure", NULL); code = TCL_ERROR; goto done; } @@ -396,18 +431,30 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) } /* - * Record the fact that the package has been loaded in the - * target interpreter. + * Record the fact that the package has been loaded in the target + * interpreter. */ 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! */ - ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", - (Tcl_InterpDeleteProc **) NULL); + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, + "tclLoad", NULL); ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; @@ -417,11 +464,434 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) TclTransferResult(target, code, interp); } - done: + done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); + Tcl_DStringFree(&unloadName); + Tcl_DStringFree(&safeUnloadName); + Tcl_DStringFree(&tmp); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnloadObjCmd -- + * + * This function 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( + 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, *defaultPtr; + Tcl_DString pkgName, tmp; + Tcl_PackageUnloadProc *unloadProc; + InterpPackage *ipFirstPtr, *ipPtr; + int i, index, code, complain = 1, keepLibrary = 0; + int trustedRefCount = -1, safeRefCount = -1; + const 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", 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", 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", 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", 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", 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", NULL); + code = TCL_ERROR; + goto done; + } + unloadProc = pkgPtr->unloadProc; + } + + /* + * We are ready to unload the package. First, evaluate the unload + * function. 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 function 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); + if ((pkgPtr->unloadProc != NULL) || (unLoadProcPtr == TclFSUnloadTempFile)) { + (*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", 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", + NULL); + code = TCL_ERROR; + } + } +#else + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded: unloading disabled", 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; } @@ -430,37 +900,37 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) * * Tcl_StaticPackage -- * - * This procedure is invoked to indicate that a particular - * package has been linked statically with an application. + * This function is invoked to indicate that a particular package has + * been linked statically with an application. * * Results: * None. * * Side effects: - * Once this procedure completes, the package becomes loadable - * via the "load" command with an empty file name. + * Once this function completes, the package becomes loadable via the + * "load" command with an empty file name. * *---------------------------------------------------------------------- */ void -Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) - Tcl_Interp *interp; /* If not NULL, it means that the - * package has already been loaded - * into the given interpreter by - * calling the appropriate init proc. */ - CONST char *pkgName; /* Name of package (must be properly - * capitalized: first letter upper - * case, others lower case). */ - Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate - * this package into a trusted - * interpreter. */ - Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate - * this package into a safe interpreter - * (one that will execute untrusted - * scripts). NULL means the package - * can't be used in safe - * interpreters. */ +Tcl_StaticPackage( + Tcl_Interp *interp, /* If not NULL, it means that the package has + * already been loaded into the given + * interpreter by calling the appropriate init + * proc. */ + const char *pkgName, /* Name of package (must be properly + * capitalized: first letter upper case, + * others lower case). */ + Tcl_PackageInitProc *initProc, + /* Function to call to incorporate this + * package into a trusted interpreter. */ + Tcl_PackageInitProc *safeInitProc) + /* Function to call to incorporate this + * package into a safe interpreter (one that + * will execute untrusted scripts). NULL means + * the package can't be used in safe + * interpreters. */ { LoadedPackage *pkgPtr; InterpPackage *ipPtr, *ipFirstPtr; @@ -481,16 +951,16 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) Tcl_MutexUnlock(&packageMutex); /* - * If the package is not yet recorded as being loaded statically, - * add it to the list now. + * If the package is not yet recorded as being loaded statically, add it + * to the list now. */ if ( pkgPtr == NULL ) { pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); pkgPtr->fileName = (char *) ckalloc((unsigned) 1); pkgPtr->fileName[0] = 0; - pkgPtr->packageName = (char *) ckalloc((unsigned) - (strlen(pkgName) + 1)); + pkgPtr->packageName = (char *) + ckalloc((unsigned) (strlen(pkgName) + 1)); strcpy(pkgPtr->packageName, pkgName); pkgPtr->loadHandle = NULL; pkgPtr->initProc = initProc; @@ -504,12 +974,12 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) if (interp != NULL) { /* - * If we're loading the package into an interpreter, - * determine whether it's already loaded. + * If we're loading the package into an interpreter, determine whether + * it's already loaded. */ - ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", - (Tcl_InterpDeleteProc **) NULL); + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, + "tclLoad", NULL); for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) { if ( ipPtr->pkgPtr == pkgPtr ) { return; @@ -517,8 +987,8 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) } /* - * Package isn't loade in the current interp yet. Mark it as - * now being loaded. + * Package isn't loade in the current interp yet. Mark it as now being + * loaded. */ ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); @@ -534,17 +1004,15 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * * TclGetLoadedPackages -- * - * This procedure returns information about all of the files - * that are loaded (either in a particular intepreter, or - * for all interpreters). + * This function returns information about all of the files that are + * loaded (either in a particular intepreter, or for all interpreters). * * Results: - * The return value is a standard Tcl completion code. If - * successful, a list of lists is placed in the interp's result. - * Each sublist corresponds to one loaded file; its first - * element is the name of the file (or an empty string for - * something that's statically loaded) and the second element - * is the name of the package in that file. + * The return value is a standard Tcl completion code. If successful, a + * list of lists is placed in the interp's result. Each sublist + * corresponds to one loaded file; its first element is the name of the + * file (or an empty string for something that's statically loaded) and + * the second element is the name of the package in that file. * * Side effects: * None. @@ -553,21 +1021,21 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) */ int -TclGetLoadedPackages(interp, targetName) - Tcl_Interp *interp; /* Interpreter in which to return - * information or error message. */ - char *targetName; /* Name of target interpreter or NULL. - * If NULL, return info about all interps; +TclGetLoadedPackages( + Tcl_Interp *interp, /* Interpreter in which to return information + * or error message. */ + char *targetName) /* Name of target interpreter or NULL. If + * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ { Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; - char *prefix; + const char *prefix; if (targetName == NULL) { - /* + /* * Return information about all of the available packages. */ @@ -575,10 +1043,10 @@ TclGetLoadedPackages(interp, targetName) Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendResult(interp, prefix, NULL); Tcl_AppendElement(interp, pkgPtr->fileName); Tcl_AppendElement(interp, pkgPtr->packageName); - Tcl_AppendResult(interp, "}", (char *) NULL); + Tcl_AppendResult(interp, "}", NULL); prefix = " {"; } Tcl_MutexUnlock(&packageMutex); @@ -586,23 +1054,22 @@ TclGetLoadedPackages(interp, targetName) } /* - * Return information about only the packages that are loaded in - * a given interpreter. + * Return information about only the packages that are loaded in a given + * interpreter. */ target = Tcl_GetSlave(interp, targetName); if (target == NULL) { return TCL_ERROR; } - ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", - (Tcl_InterpDeleteProc **) NULL); + ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", NULL); prefix = "{"; for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; - Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendResult(interp, prefix, NULL); Tcl_AppendElement(interp, pkgPtr->fileName); Tcl_AppendElement(interp, pkgPtr->packageName); - Tcl_AppendResult(interp, "}", (char *) NULL); + Tcl_AppendResult(interp, "}", NULL); prefix = " {"; } return TCL_OK; @@ -613,25 +1080,24 @@ TclGetLoadedPackages(interp, targetName) * * LoadCleanupProc -- * - * This procedure is called to delete all of the InterpPackage - * structures for an interpreter when the interpreter is deleted. - * It gets invoked via the Tcl AssocData mechanism. + * This function is called to delete all of the InterpPackage structures + * for an interpreter when the interpreter is deleted. It gets invoked + * via the Tcl AssocData mechanism. * * Results: * None. * * Side effects: - * Storage for all of the InterpPackage procedures for interp - * get deleted. + * Storage for all of the InterpPackage functions for interp get deleted. * *---------------------------------------------------------------------- */ static void -LoadCleanupProc(clientData, interp) - ClientData clientData; /* Pointer to first InterpPackage structure +LoadCleanupProc( + ClientData clientData, /* Pointer to first InterpPackage structure * for interp. */ - Tcl_Interp *interp; /* Interpreter that is being deleted. */ + Tcl_Interp *interp) /* Interpreter that is being deleted. */ { InterpPackage *ipPtr, *nextPtr; @@ -648,8 +1114,8 @@ LoadCleanupProc(clientData, interp) * * TclFinalizeLoad -- * - * This procedure is invoked just before the application exits. - * It frees all of the LoadedPackage structures. + * This function is invoked just before the application exits. It frees + * all of the LoadedPackage structures. * * Results: * None. @@ -661,38 +1127,49 @@ LoadCleanupProc(clientData, interp) */ void -TclFinalizeLoad() +TclFinalizeLoad(void) { LoadedPackage *pkgPtr; /* - * No synchronization here because there should just be - * one thread alive at this point. Logically, - * packageMutex should be grabbed at this point, but - * the Mutexes get finalized before the call to this routine. - * The only subsystem left alive at this point is the - * memory allocator. + * No synchronization here because there should just be one thread alive + * at this point. Logically, packageMutex should be grabbed at this point, + * but the Mutexes get finalized before the call to this routine. The + * only subsystem left alive at this point is the memory allocator. */ while (firstPackagePtr != NULL) { pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; + #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. + * 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 has been unloaded. */ + if (pkgPtr->fileName[0] != '\0') { Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; - if (unLoadProcPtr != NULL) { - (*unLoadProcPtr)(pkgPtr->loadHandle); + if ((unLoadProcPtr != NULL) + && ((pkgPtr->unloadProc != NULL) + || (unLoadProcPtr == TclFSUnloadTempFile))) { + (*unLoadProcPtr)(pkgPtr->loadHandle); } } #endif + ckfree(pkgPtr->fileName); ckfree(pkgPtr->packageName); ckfree((char *) pkgPtr); } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |