diff options
Diffstat (limited to 'generic/tclLoad.c')
| -rw-r--r-- | generic/tclLoad.c | 919 |
1 files changed, 236 insertions, 683 deletions
diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 008a99d..0caa28b 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -1,64 +1,59 @@ -/* +/* * 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 function to call to + /* Initialization procedure to call to * incorporate this package into a trusted * interpreter. */ Tcl_PackageInitProc *safeInitProc; - /* Initialization function to call to + /* Initialization 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 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. */ + * untrusted scripts). NULL means the + * package can't be used in unsafe + * 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. */ 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; /* @@ -74,35 +69,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 - * 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). + * 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). */ 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 functions that are private to this file: + * Prototypes for procedures that are private to this file: */ -static void LoadCleanupProc(ClientData clientData, - Tcl_Interp *interp); +static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); /* *---------------------------------------------------------------------- * * Tcl_LoadObjCmd -- * - * This function is invoked to process the "load" Tcl command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the "load" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -114,39 +109,36 @@ static void LoadCleanupProc(ClientData clientData, */ int -Tcl_LoadObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; Tcl_DString pkgName, tmp, initName, safeInitName; - Tcl_DString unloadName, safeUnloadName; + Tcl_PackageInitProc *initProc, *safeInitProc; InterpPackage *ipFirstPtr, *ipPtr; - int code, namesMatch, filesMatch, offset; - const char *symbols[2]; - Tcl_PackageInitProc *initProc; - const char *p, *fullFileName, *packageName; + int code, namesMatch, filesMatch; + char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; + Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; Tcl_UniChar ch; - unsigned len; + 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; @@ -160,8 +152,6 @@ Tcl_LoadObjCmd( Tcl_SetResult(interp, "must specify either file name or package name", TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", - NULL); code = TCL_ERROR; goto done; } @@ -172,25 +162,23 @@ Tcl_LoadObjCmd( target = interp; if (objc == 4) { - const char *slaveIntName = Tcl_GetString(objv[3]); - + char *slaveIntName; + slaveIntName = Tcl_GetString(objv[3]); target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { - code = TCL_ERROR; - goto done; + 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: + * 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; @@ -222,14 +210,13 @@ Tcl_LoadObjCmd( } 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, "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "SPLITPERSONALITY", NULL); + pkgPtr->packageName, "\"", (char *) NULL); code = TCL_ERROR; Tcl_MutexUnlock(&packageMutex); goto done; @@ -242,12 +229,13 @@ Tcl_LoadObjCmd( /* * 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 do. + * interpreter. If the package we want is already loaded there, + * then there's nothing for us to to. */ if (pkgPtr != NULL) { - ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", 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; @@ -258,15 +246,13 @@ Tcl_LoadObjCmd( 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", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", - NULL); + "\" isn't loaded statically", (char *) NULL); code = TCL_ERROR; goto done; } @@ -279,23 +265,22 @@ Tcl_LoadObjCmd( 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, *pkgGuessPtr; + Tcl_Obj *splitPtr; + Tcl_Obj *pkgGuessPtr; int pElements; - const char *pkgGuess; + 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); @@ -323,9 +308,7 @@ Tcl_LoadObjCmd( Tcl_DecrRefCount(splitPtr); Tcl_AppendResult(interp, "couldn't figure out package name for ", - fullFileName, NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "WHATPACKAGE", NULL); + fullFileName, (char *) NULL); code = TCL_ERROR; goto done; } @@ -339,544 +322,112 @@ Tcl_LoadObjCmd( * 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 functions, based on the - * package name. + * Compute the names of the two initialization procedures, + * 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 functions. + * Call platform-specific code to load the package and find the + * two initialization procedures. */ - symbols[0] = Tcl_DStringValue(&initName); - symbols[1] = NULL; - Tcl_MutexLock(&packageMutex); - code = Tcl_LoadFile(interp, objv[1], symbols, 0, &initProc, - &loadHandle); + code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName), + Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc, + &loadHandle,&unLoadProcPtr); Tcl_MutexUnlock(&packageMutex); if (code != TCL_OK) { goto done; } + if (initProc == NULL) { + Tcl_AppendResult(interp, "couldn't find procedure ", + Tcl_DStringValue(&initName), (char *) NULL); + if (unLoadProcPtr != NULL) { + (*unLoadProcPtr)(loadHandle); + } + code = TCL_ERROR; + goto done; + } /* * Create a new record to describe this package. */ - pkgPtr = ckalloc(sizeof(LoadedPackage)); - len = strlen(fullFileName) + 1; - pkgPtr->fileName = ckalloc(len); - memcpy(pkgPtr->fileName, fullFileName, len); - len = (unsigned) Tcl_DStringLength(&pkgName) + 1; - pkgPtr->packageName = ckalloc(len); - memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); - pkgPtr->loadHandle = loadHandle; - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = (Tcl_PackageInitProc *) - Tcl_FindSymbol(interp, loadHandle, - Tcl_DStringValue(&safeInitName)); - pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) - Tcl_FindSymbol(interp, loadHandle, - Tcl_DStringValue(&unloadName)); - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc *) - Tcl_FindSymbol(interp, loadHandle, - Tcl_DStringValue(&safeUnloadName)); - pkgPtr->interpRefCount = 0; - pkgPtr->safeInterpRefCount = 0; - + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) + (strlen(fullFileName) + 1)); + strcpy(pkgPtr->fileName, fullFileName); + 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; Tcl_MutexLock(&packageMutex); - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; Tcl_MutexUnlock(&packageMutex); - - /* - * The Tcl_FindSymbol calls may have left a spurious error message in - * the interpreter result. - */ - - Tcl_ResetResult(interp); - } - - /* - * 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)) { - if (pkgPtr->safeInitProc == NULL) { - Tcl_AppendResult(interp, - "can't use package in a safe interpreter: no ", - pkgPtr->packageName, "_SafeInit procedure", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", - NULL); - code = TCL_ERROR; - goto done; - } - code = pkgPtr->safeInitProc(target); - } else { - if (pkgPtr->initProc == NULL) { - Tcl_AppendResult(interp, - "can't attach package to interpreter: no ", - pkgPtr->packageName, "_Init procedure", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", - NULL); - code = TCL_ERROR; - goto done; - } - code = pkgPtr->initProc(target); - } - - /* - * Test for whether the initialization failed. If so, transfer the error - * from the target interpreter to the originating one. - */ - - if (code != TCL_OK) { - Tcl_TransferResult(target, code, interp); - goto done; } /* - * Record the fact that the package has been loaded in the target - * interpreter. - * - * Update the proper reference count. + * Invoke the package's initialization procedure (either the + * normal one or the safe one, depending on whether or not the + * interpreter is safe). */ - 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 = Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = ckalloc(sizeof(InterpPackage)); - ipPtr->pkgPtr = pkgPtr; - ipPtr->nextPtr = ipFirstPtr; - Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); - - 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 = ""; - const char *packageName; - static const char *const 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, - "?-switch ...? 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); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", - NULL); - code = TCL_ERROR; - goto done; - } - - /* - * Figure out which interpreter we're going to load the package into. - */ - - target = interp; - if (objc - i == 3) { - const char *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; + if (pkgPtr->safeInitProc != NULL) { + code = (*pkgPtr->safeInitProc)(target); } 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); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", - 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); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", - 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 = 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); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", - 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); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - NULL); + Tcl_AppendResult(interp, + "can't use package in a safe interpreter: ", + "no ", pkgPtr->packageName, "_SafeInit procedure", + (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", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - 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) { - Tcl_TransferResult(target, code, interp); - goto done; + code = (*pkgPtr->initProc)(target); } /* - * The unload function executed fine. Examine the reference count to see - * if we unload the DLL. + * Record the fact that the package has been loaded in the + * target interpreter. */ - Tcl_MutexLock(&packageMutex); - if (Tcl_IsSafe(target)) { - pkgPtr->safeInterpRefCount--; - + if (code == TCL_OK) { /* - * Do not let counter get negative. + * Refetch ipFirstPtr: loading the package may have introduced + * additional static packages at the head of the linked list! */ - if (pkgPtr->safeInterpRefCount < 0) { - pkgPtr->safeInterpRefCount = 0; - } + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); } 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_MutexLock(&packageMutex); - if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { - /* - * 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 = 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, - ipFirstPtr); - ckfree(defaultPtr->fileName); - ckfree(defaultPtr->packageName); - ckfree(defaultPtr); - ckfree(ipPtr); - Tcl_MutexUnlock(&packageMutex); - } else { - code = TCL_ERROR; - } - } -#else - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded: unloading disabled", NULL); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", - NULL); - code = TCL_ERROR; -#endif + TclTransferResult(target, code, interp); } - done: + done: Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&initName); + Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&tmp); - if (!complain && (code != TCL_OK)) { - code = TCL_OK; - Tcl_ResetResult(interp); - } return code; } @@ -885,37 +436,37 @@ Tcl_UnloadObjCmd( * * Tcl_StaticPackage -- * - * This function is invoked to indicate that a particular package has - * been linked statically with an application. + * This procedure is invoked to indicate that a particular + * package has been linked statically with an application. * * Results: * None. * * Side effects: - * Once this function completes, the package becomes loadable via the - * "load" command with an empty file name. + * Once this procedure completes, the package becomes loadable + * via the "load" command with an empty file name. * *---------------------------------------------------------------------- */ void -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. */ +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. */ { LoadedPackage *pkgPtr; InterpPackage *ipPtr, *ipFirstPtr; @@ -936,15 +487,16 @@ Tcl_StaticPackage( 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 = ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = ckalloc(1); + if ( pkgPtr == NULL ) { + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) 1); pkgPtr->fileName[0] = 0; - pkgPtr->packageName = ckalloc(strlen(pkgName) + 1); + pkgPtr->packageName = (char *) ckalloc((unsigned) + (strlen(pkgName) + 1)); strcpy(pkgPtr->packageName, pkgName); pkgPtr->loadHandle = NULL; pkgPtr->initProc = initProc; @@ -958,26 +510,28 @@ Tcl_StaticPackage( 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 = Tcl_GetAssocData(interp, "tclLoad", NULL); - for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->pkgPtr == pkgPtr) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) { + if ( ipPtr->pkgPtr == pkgPtr ) { return; } } /* - * 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 = ckalloc(sizeof(InterpPackage)); + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; - Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); + Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); } } @@ -986,15 +540,17 @@ Tcl_StaticPackage( * * TclGetLoadedPackages -- * - * This function returns information about all of the files that are - * loaded (either in a particular intepreter, or for all interpreters). + * This procedure 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. @@ -1003,56 +559,58 @@ Tcl_StaticPackage( */ int -TclGetLoadedPackages( - Tcl_Interp *interp, /* Interpreter in which to return information - * or error message. */ - const char *targetName) /* Name of target interpreter or NULL. If - * NULL, return info about all interps; +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; * otherwise, just return info about this * interpreter. */ { Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; - Tcl_Obj *resultObj, *pkgDesc[2]; + char *prefix; if (targetName == NULL) { - /* + /* * Return information about all of the available packages. */ - resultObj = Tcl_NewObj(); + prefix = "{"; Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewListObj(2, pkgDesc)); + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; } Tcl_MutexUnlock(&packageMutex); - Tcl_SetObjResult(interp, resultObj); return TCL_OK; } /* - * 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 = Tcl_GetAssocData(target, "tclLoad", NULL); - resultObj = Tcl_NewObj(); - for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + prefix = "{"; + for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; - pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; } - Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1061,31 +619,32 @@ TclGetLoadedPackages( * * LoadCleanupProc -- * - * 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. + * 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. * * Results: * None. * * Side effects: - * Storage for all of the InterpPackage functions for interp get deleted. + * Storage for all of the InterpPackage procedures for interp + * get deleted. * *---------------------------------------------------------------------- */ static void -LoadCleanupProc( - ClientData clientData, /* Pointer to first InterpPackage structure +LoadCleanupProc(clientData, interp) + 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; - ipPtr = clientData; + ipPtr = (InterpPackage *) clientData; while (ipPtr != NULL) { nextPtr = ipPtr->nextPtr; - ckfree(ipPtr); + ckfree((char *) ipPtr); ipPtr = nextPtr; } } @@ -1095,8 +654,8 @@ LoadCleanupProc( * * TclFinalizeLoad -- * - * This function is invoked just before the application exits. It frees - * all of the LoadedPackage structures. + * This procedure is invoked just before the application exits. + * It frees all of the LoadedPackage structures. * * Results: * None. @@ -1108,44 +667,38 @@ LoadCleanupProc( */ void -TclFinalizeLoad(void) +TclFinalizeLoad() { 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 has 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's been unloaded. */ - if (pkgPtr->fileName[0] != '\0') { - Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle); + Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; + if (unLoadProcPtr != NULL) { + (*unLoadProcPtr)(pkgPtr->loadHandle); + } } #endif - ckfree(pkgPtr->fileName); ckfree(pkgPtr->packageName); - ckfree(pkgPtr); + ckfree((char *) pkgPtr); } } - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |