diff options
Diffstat (limited to 'generic/tclLoad.c')
| -rw-r--r-- | generic/tclLoad.c | 1179 |
1 files changed, 538 insertions, 641 deletions
diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 05883ba..ac863b9 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -4,7 +4,7 @@ * This file provides the generic portion (those that are the same on all * platforms) of Tcl's dynamic loading facilities. * - * Copyright © 1995-1997 Sun Microsystems, Inc. + * 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. @@ -12,102 +12,94 @@ #include "tclInt.h" - /* - * The following structure describes a library that has been loaded either + * The following structure describes a package that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call - * to Tcl_StaticLibrary). All such libraries are linked together into a - * single list for the process. Library are never unloaded, until the + * 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 LoadedLibrary { - char *fileName; /* Name of the file from which the library was - * loaded. An empty string means the library +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 *prefix; /* Prefix for the library, + char *packageName; /* Name of package prefix for the package, * properly capitalized (first letter UC, - * others LC), 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, * then this field is irrelevant. */ - Tcl_LibraryInitProc *initProc; + Tcl_PackageInitProc *initProc; /* Initialization function to call to - * incorporate this library into a trusted + * incorporate this package into a trusted * interpreter. */ - Tcl_LibraryInitProc *safeInitProc; + Tcl_PackageInitProc *safeInitProc; /* Initialization function to call to - * incorporate this library into a safe + * incorporate this package into a safe * interpreter (one that will execute - * untrusted scripts). NULL means the library + * untrusted scripts). NULL means the package * can't be used in unsafe interpreters. */ - Tcl_LibraryUnloadProc *unloadProc; - /* Finalization function to unload a library + Tcl_PackageUnloadProc *unloadProc; + /* Finalisation function to unload a package * from a trusted interpreter. NULL means that - * the library cannot be unloaded. */ - Tcl_LibraryUnloadProc *safeUnloadProc; - /* Finalization function to unload a library + * the package cannot be unloaded. */ + Tcl_PackageUnloadProc *safeUnloadProc; + /* Finalisation function to unload a package * from a safe interpreter. NULL means that - * the library cannot be unloaded. */ - int interpRefCount; /* How many times the library has been loaded + * the package cannot be unloaded. */ + int interpRefCount; /* How many times the package has been loaded * in trusted interpreters. */ - int safeInterpRefCount; /* How many times the library has been loaded + int safeInterpRefCount; /* How many times the package has been loaded * in safe interpreters. */ - struct LoadedLibrary *nextPtr; - /* Next in list of all libraries loaded into + Tcl_FSUnloadFileProc *unLoadProcPtr; + /* 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. */ -} LoadedLibrary; +} LoadedPackage; /* * TCL_THREADS - * There is a global list of libraries that is anchored at firstLibraryPtr. + * There is a global list of packages that is anchored at firstPackagePtr. * Access to this list is governed by a mutex. */ -static LoadedLibrary *firstLibraryPtr = NULL; - /* First in list of all libraries loaded into +static LoadedPackage *firstPackagePtr = NULL; + /* First in list of all packages loaded into * this process. */ -TCL_DECLARE_MUTEX(libraryMutex) +TCL_DECLARE_MUTEX(packageMutex) /* - * The following structure represents a particular library that has been + * 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 library (if any). + * first package (if any). */ -typedef struct InterpLibrary { - LoadedLibrary *libraryPtr; /* Points to detailed information about - * library. */ - struct InterpLibrary *nextPtr; - /* Next library in this interpreter, or NULL +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. */ -} InterpLibrary; +} InterpPackage; /* * Prototypes for functions that are private to this file: */ -static void LoadCleanupProc(ClientData clientData, - Tcl_Interp *interp); -static int IsStatic (LoadedLibrary *libraryPtr); -static int UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target, - LoadedLibrary *library, int keepLibrary, - const char *fullFileName, int interpExiting); - - -static int -IsStatic (LoadedLibrary *libraryPtr) { - int res; - res = (libraryPtr->fileName[0] == '\0'); - return res; -} +static void LoadCleanupProc(ClientData clientData, + Tcl_Interp *interp); /* *---------------------------------------------------------------------- @@ -128,51 +120,28 @@ IsStatic (LoadedLibrary *libraryPtr) { int Tcl_LoadObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; - LoadedLibrary *libraryPtr, *defaultPtr; - Tcl_DString pfx, tmp, initName, safeInitName; + LoadedPackage *pkgPtr, *defaultPtr; + Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; - InterpLibrary *ipFirstPtr, *ipPtr; + Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc; + InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; - const char *symbols[2]; - Tcl_LibraryInitProc *initProc; - const char *p, *fullFileName, *prefix; + const char *symbols[4]; + Tcl_PackageInitProc **procPtrs[4]; + ClientData clientData; + char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; - Tcl_UniChar ch = 0; - unsigned len; - int index, flags = 0; - Tcl_Obj *const *savedobjv = objv; - static const char *const options[] = { - "-global", "-lazy", "--", NULL - }; - enum loadOptionsEnum { - LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST - }; + Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; + Tcl_UniChar ch; - while (objc > 2) { - if (TclGetString(objv[1])[0] != '-') { - break; - } - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - ++objv; --objc; - if (LOAD_GLOBAL == (enum loadOptionsEnum) index) { - flags |= TCL_LOAD_GLOBAL; - } else if (LOAD_LAZY == (enum loadOptionsEnum) index) { - flags |= TCL_LOAD_LAZY; - } else { - break; - } - } if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"); + Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { @@ -180,38 +149,37 @@ Tcl_LoadObjCmd( } fullFileName = Tcl_GetString(objv[1]); - Tcl_DStringInit(&pfx); + Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); Tcl_DStringInit(&unloadName); Tcl_DStringInit(&safeUnloadName); Tcl_DStringInit(&tmp); - prefix = NULL; + packageName = NULL; if (objc >= 3) { - prefix = Tcl_GetString(objv[2]); - if (prefix[0] == '\0') { - prefix = NULL; + packageName = Tcl_GetString(objv[2]); + if (packageName[0] == '\0') { + packageName = NULL; } } - if ((fullFileName[0] == 0) && (prefix == NULL)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or prefix", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", - (void *)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 library into. + * Figure out which interpreter we're going to load the package into. */ target = interp; if (objc == 4) { - const char *childIntName = Tcl_GetString(objv[3]); + char *slaveIntName = Tcl_GetString(objv[3]); - target = Tcl_GetChild(interp, childIntName); + target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { code = TCL_ERROR; goto done; @@ -219,318 +187,291 @@ Tcl_LoadObjCmd( } /* - * Scan through the libraries that are currently loaded to see if the - * library we want is already loaded. We'll use a loaded library if it + * 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 library with the same prefix. + * only no statically loaded package with the same name. */ - Tcl_MutexLock(&libraryMutex); + Tcl_MutexLock(&packageMutex); defaultPtr = NULL; - for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { - if (prefix == NULL) { + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + if (packageName == NULL) { namesMatch = 0; } else { - TclDStringClear(&pfx); - Tcl_DStringAppend(&pfx, prefix, -1); - TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pfx)); + 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(&pfx)) == 0) { + Tcl_DStringValue(&pkgName)) == 0) { namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pfx); + Tcl_DStringSetLength(&pkgName, 0); - filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (prefix == NULL))) { + filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); + if (filesMatch && (namesMatch || (packageName == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { - defaultPtr = libraryPtr; + defaultPtr = pkgPtr; } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* - * Can't have two different libraries loaded from the same file. + * Can't have two different packages loaded from the same file. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" is already loaded for prefix \"%s\"", - fullFileName, libraryPtr->prefix)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "SPLITPERSONALITY", (void *)NULL); + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" is already loaded for package \"", + pkgPtr->packageName, "\"", NULL); code = TCL_ERROR; - Tcl_MutexUnlock(&libraryMutex); + Tcl_MutexUnlock(&packageMutex); goto done; } } - Tcl_MutexUnlock(&libraryMutex); - if (libraryPtr == NULL) { - libraryPtr = defaultPtr; + Tcl_MutexUnlock(&packageMutex); + if (pkgPtr == NULL) { + pkgPtr = defaultPtr; } /* - * Scan through the list of libraries already loaded in the target - * interpreter. If the library we want is already loaded there, then + * 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. */ - if (libraryPtr != NULL) { - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + if (pkgPtr != NULL) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, + "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->libraryPtr == libraryPtr) { + if (ipPtr->pkgPtr == pkgPtr) { code = TCL_OK; goto done; } } } - if (libraryPtr == NULL) { + if (pkgPtr == NULL) { /* * The desired file isn't currently loaded, so load it. It's an error - * if the desired library is a static one. + * if the desired package is a static one. */ if (fullFileName[0] == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no library with prefix \"%s\" is loaded statically", prefix)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", - (void *)NULL); + Tcl_AppendResult(interp, "package \"", packageName, + "\" isn't loaded statically", NULL); code = TCL_ERROR; goto done; } /* - * Figure out the prefix if it wasn't provided explicitly. + * Figure out the module name if it wasn't provided explicitly. */ - if (prefix != NULL) { - Tcl_DStringAppend(&pfx, prefix, -1); + if (packageName != NULL) { + Tcl_DStringAppend(&pkgName, packageName, -1); } else { - Tcl_Obj *splitPtr, *pkgGuessPtr; - int pElements; - const char *pkgGuess; + int retc; /* * Threading note - this call used to be protected by a mutex. */ - /* - * The platform-specific code couldn't figure out the prefix. - * Make a guess by taking the last element of the file - * name, stripping off any leading "lib" and/or "tcl", and - * then using all of the alphabetic and underline characters - * that follow that. - */ + retc = TclGuessPackageName(fullFileName, &pkgName); + if (!retc) { + Tcl_Obj *splitPtr; + Tcl_Obj *pkgGuessPtr; + int pElements; + char *pkgGuess; - splitPtr = Tcl_FSSplitPath(objv[1], &pElements); - Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); - pkgGuess = Tcl_GetString(pkgGuessPtr); - if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') - && (pkgGuess[2] == 'b')) { - pkgGuess += 3; - } + /* + * 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); + Tcl_ListObjIndex(NULL, splitPtr, pElements -1, &pkgGuessPtr); + pkgGuess = Tcl_GetString(pkgGuessPtr); + if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') + && (pkgGuess[2] == 'b')) { + pkgGuess += 3; + } #ifdef __CYGWIN__ - else if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y') - && (pkgGuess[2] == 'g')) { - pkgGuess += 3; - } + if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y') + && (pkgGuess[2] == 'g')) { + pkgGuess += 3; + } #endif /* __CYGWIN__ */ - if (((pkgGuess[0] == 't') -#ifdef MAC_OSX_TCL - || (pkgGuess[0] == 'T') -#endif - ) && (pkgGuess[1] == 'c') - && (pkgGuess[2] == 'l')) { - pkgGuess += 3; - } - for (p = pkgGuess; *p != 0; p += offset) { - offset = TclUtfToUniChar(p, &ch); - if ((ch > 0x100) - || !(isalpha(UCHAR(ch)) /* INTL: ISO only */ - || (UCHAR(ch) == '_'))) { - break; + for (p = pkgGuess; *p != 0; p += offset) { + offset = Tcl_UtfToUniChar(p, &ch); + if ((ch > 0x100) + || !(isalpha(UCHAR(ch)) /* INTL: ISO only */ + || (UCHAR(ch) == '_'))) { + break; + } } - } - if (p == pkgGuess) { + if (p == pkgGuess) { + Tcl_DecrRefCount(splitPtr); + Tcl_AppendResult(interp, + "couldn't figure out package name for ", + fullFileName, NULL); + code = TCL_ERROR; + goto done; + } + Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); Tcl_DecrRefCount(splitPtr); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't figure out prefix for %s", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", - "WHATLIBRARY", (void *)NULL); - code = TCL_ERROR; - goto done; } - Tcl_DStringAppend(&pfx, pkgGuess, p - pkgGuess); - Tcl_DecrRefCount(splitPtr); } /* - * Fix the capitalization in the prefix so that the first + * Fix the capitalization in the package name so that the first * character is in caps (or title case) but the others are all * lower-case. */ - Tcl_DStringSetLength(&pfx, - Tcl_UtfToTitle(Tcl_DStringValue(&pfx))); + Tcl_DStringSetLength(&pkgName, + Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); /* * Compute the names of the two initialization functions, based on the - * prefix. + * package name. */ - TclDStringAppendDString(&initName, &pfx); - TclDStringAppendLiteral(&initName, "_Init"); - TclDStringAppendDString(&safeInitName, &pfx); - TclDStringAppendLiteral(&safeInitName, "_SafeInit"); - TclDStringAppendDString(&unloadName, &pfx); - TclDStringAppendLiteral(&unloadName, "_Unload"); - TclDStringAppendDString(&safeUnloadName, &pfx); - TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); + 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 library and find the two + * Call platform-specific code to load the package and find the two * initialization functions. */ symbols[0] = Tcl_DStringValue(&initName); - symbols[1] = NULL; - - Tcl_MutexLock(&libraryMutex); - code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc, - &loadHandle); - Tcl_MutexUnlock(&libraryMutex); + 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 = TclLoadFile(interp, objv[1], 4, symbols, procPtrs, + &loadHandle, &clientData, &unLoadProcPtr); + Tcl_MutexUnlock(&packageMutex); + loadHandle = (Tcl_LoadHandle) clientData; if (code != TCL_OK) { goto done; } - /* - * Create a new record to describe this library. - */ - - libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary)); - len = strlen(fullFileName) + 1; - libraryPtr->fileName = (char *)ckalloc(len); - memcpy(libraryPtr->fileName, fullFileName, len); - len = Tcl_DStringLength(&pfx) + 1; - libraryPtr->prefix = (char *)ckalloc(len); - memcpy(libraryPtr->prefix, Tcl_DStringValue(&pfx), len); - libraryPtr->loadHandle = loadHandle; - libraryPtr->initProc = initProc; - libraryPtr->safeInitProc = (Tcl_LibraryInitProc *) - Tcl_FindSymbol(interp, loadHandle, - Tcl_DStringValue(&safeInitName)); - libraryPtr->unloadProc = (Tcl_LibraryUnloadProc *) - Tcl_FindSymbol(interp, loadHandle, - Tcl_DStringValue(&unloadName)); - libraryPtr->safeUnloadProc = (Tcl_LibraryUnloadProc *) - Tcl_FindSymbol(interp, loadHandle, - Tcl_DStringValue(&safeUnloadName)); - libraryPtr->interpRefCount = 0; - libraryPtr->safeInterpRefCount = 0; - - Tcl_MutexLock(&libraryMutex); - libraryPtr->nextPtr = firstLibraryPtr; - firstLibraryPtr = libraryPtr; - Tcl_MutexUnlock(&libraryMutex); + if (*procPtrs[0] /* initProc */ == NULL) { + Tcl_AppendResult(interp, "couldn't find procedure ", + Tcl_DStringValue(&initName), NULL); + if (unLoadProcPtr != NULL) { + (*unLoadProcPtr)(loadHandle); + } + code = TCL_ERROR; + goto done; + } /* - * The Tcl_FindSymbol calls may have left a spurious error message in - * the interpreter result. + * Create a new record to describe this package. */ - Tcl_ResetResult(interp); + 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 = *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; + Tcl_MutexUnlock(&packageMutex); } /* - * Invoke the library's initialization function (either the normal one or + * 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 (libraryPtr->safeInitProc == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use library in a safe interpreter: no" - " %s_SafeInit procedure", libraryPtr->prefix)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", - (void *)NULL); + if (pkgPtr->safeInitProc != NULL) { + code = (*pkgPtr->safeInitProc)(target); + } else { + Tcl_AppendResult(interp, + "can't use package in a safe interpreter: no ", + pkgPtr->packageName, "_SafeInit procedure", NULL); code = TCL_ERROR; goto done; } - code = libraryPtr->safeInitProc(target); } else { - if (libraryPtr->initProc == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't attach library to interpreter: no %s_Init procedure", - libraryPtr->prefix)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", - (void *)NULL); - code = TCL_ERROR; - goto done; - } - code = libraryPtr->initProc(target); + code = (*pkgPtr->initProc)(target); } /* - * Test for whether the initialization failed. If so, transfer the error - * from the target interpreter to the originating one. + * Record the fact that the package has been loaded in the target + * interpreter. */ - if (code != TCL_OK) { -#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 - Interp *iPtr = (Interp *) target; - if (iPtr->result && *(iPtr->result) && !iPtr->freeProc) { - /* - * A call to Tcl_InitStubs() determined the caller extension and - * this interp are incompatible in their stubs mechanisms, and - * recorded the error in the oldest legacy place we have to do so. - */ - Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->result, -1)); - iPtr->result = &tclEmptyString; - iPtr->freeProc = NULL; + if (code == TCL_OK) { + /* + * Update the proper reference count. + */ + + Tcl_MutexLock(&packageMutex); + if (Tcl_IsSafe(target)) { + ++pkgPtr->safeInterpRefCount; + } else { + ++pkgPtr->interpRefCount; } -#endif /* defined(TCL_NO_DEPRECATED) */ - Tcl_TransferResult(target, code, interp); - goto done; - } + Tcl_MutexUnlock(&packageMutex); - /* - * Record the fact that the library has been loaded in the target - * interpreter. - * - * Update the proper reference count. - */ + /* + * Refetch ipFirstPtr: loading the package may have introduced + * additional static packages at the head of the linked list! + */ - Tcl_MutexLock(&libraryMutex); - if (Tcl_IsSafe(target)) { - libraryPtr->safeInterpRefCount++; + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, + "tclLoad", NULL); + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); } else { - libraryPtr->interpRefCount++; + TclTransferResult(target, code, interp); } - Tcl_MutexUnlock(&libraryMutex); - - /* - * Refetch ipFirstPtr: loading the library may have introduced additional - * static libraries at the head of the linked list! - */ - - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary)); - ipPtr->libraryPtr = libraryPtr; - ipPtr->nextPtr = ipFirstPtr; - Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); done: - Tcl_DStringFree(&pfx); + Tcl_DStringFree(&pkgName); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&unloadName); @@ -544,7 +485,7 @@ Tcl_LoadObjCmd( * * Tcl_UnloadObjCmd -- * - * Implements the the "unload" Tcl command. See the + * This function is invoked to process the "unload" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -558,22 +499,24 @@ Tcl_LoadObjCmd( int Tcl_UnloadObjCmd( - TCL_UNUSED(void *), + 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. */ - LoadedLibrary *libraryPtr; - Tcl_DString pfx, tmp; - InterpLibrary *ipFirstPtr, *ipPtr; + 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 *prefix; - static const char *const options[] = { + char *packageName; + static const char *options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; - enum unloadOptionsEnum { + enum options { UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST }; @@ -598,7 +541,7 @@ Tcl_UnloadObjCmd( break; } } - switch ((enum unloadOptionsEnum)index) { + switch (index) { case UNLOAD_NOCOMPLAIN: /* -nocomplain */ complain = 0; break; @@ -613,7 +556,7 @@ Tcl_UnloadObjCmd( endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? fileName ?prefix? ?interp?"); + "?switches? fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { @@ -621,118 +564,117 @@ Tcl_UnloadObjCmd( } fullFileName = Tcl_GetString(objv[i]); - Tcl_DStringInit(&pfx); + Tcl_DStringInit(&pkgName); Tcl_DStringInit(&tmp); - prefix = NULL; + packageName = NULL; if (objc - i >= 2) { - prefix = Tcl_GetString(objv[i+1]); - if (prefix[0] == '\0') { - prefix = NULL; + packageName = Tcl_GetString(objv[i+1]); + if (packageName[0] == '\0') { + packageName = NULL; } } - if ((fullFileName[0] == 0) && (prefix == NULL)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "must specify either file name or prefix", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", - (void *)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 library into. + * Figure out which interpreter we're going to load the package into. */ target = interp; if (objc - i == 3) { - const char *childIntName = Tcl_GetString(objv[i + 2]); - - target = Tcl_GetChild(interp, childIntName); + char *slaveIntName; + slaveIntName = Tcl_GetString(objv[i+2]); + target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { return TCL_ERROR; } } /* - * Scan through the libraries that are currently loaded to see if the - * library we want is already loaded. We'll use a loaded library if it + * 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 prefix and file match the once we're looking for. - * - Its file matches, and we weren't given a prefix. - * - Its prefix matches, the file name was specified as empty, and there is - * no statically loaded library with the same prefix. + * - 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(&libraryMutex); + Tcl_MutexLock(&packageMutex); - for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { + defaultPtr = NULL; + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { int namesMatch, filesMatch; - if (prefix == NULL) { + if (packageName == NULL) { namesMatch = 0; } else { - TclDStringClear(&pfx); - Tcl_DStringAppend(&pfx, prefix, -1); - TclDStringClear(&tmp); - Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pfx)); + 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(&pfx)) == 0) { + Tcl_DStringValue(&pkgName)) == 0) { namesMatch = 1; } else { namesMatch = 0; } } - TclDStringClear(&pfx); + Tcl_DStringSetLength(&pkgName, 0); - filesMatch = (strcmp(libraryPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || (prefix == NULL))) { + 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(&libraryMutex); + Tcl_MutexUnlock(&packageMutex); if (fullFileName[0] == 0) { /* - * It's an error to try unload a static library. + * It's an error to try unload a static package. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "library with prefix \"%s\" is loaded statically and cannot be unloaded", - prefix)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", - (void *)NULL); + Tcl_AppendResult(interp, "package \"", packageName, + "\" is loaded statically and cannot be unloaded", NULL); code = TCL_ERROR; goto done; } - if (libraryPtr == NULL) { + if (pkgPtr == NULL) { /* * The DLL pointed by the provided filename has never been loaded. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" has never been loaded", fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", - (void *)NULL); + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" has never been loaded", NULL); code = TCL_ERROR; goto done; } /* - * Scan through the list of libraries already loaded in the target - * interpreter. If the library we want is already loaded there, then we + * 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 (libraryPtr != NULL) { - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); + if (pkgPtr != NULL) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, + "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->libraryPtr == libraryPtr) { + if (ipPtr->pkgPtr == pkgPtr) { code = TCL_OK; break; } @@ -740,101 +682,41 @@ Tcl_UnloadObjCmd( } if (code != TCL_OK) { /* - * The library has not been loaded in this interpreter. + * The package has not been loaded in this interpreter. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" has never been loaded in this interpreter", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", - (void *)NULL); + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" has never been loaded in this interpreter", NULL); code = TCL_ERROR; goto done; } - code = UnloadLibrary(interp, target, libraryPtr, keepLibrary, fullFileName, 0); - - done: - Tcl_DStringFree(&pfx); - Tcl_DStringFree(&tmp); - if (!complain && (code != TCL_OK)) { - code = TCL_OK; - Tcl_ResetResult(interp); - } - return code; -} - - -/* - *---------------------------------------------------------------------- - * - * UnloadLibrary -- - * - * Unloads a library from an interpreter, and also from the process if it - * is unloadable, i.e. if it provides an "unload" function. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See description. - * - *---------------------------------------------------------------------- - */ -static int -UnloadLibrary( - Tcl_Interp *interp, - Tcl_Interp *target, - LoadedLibrary *libraryPtr, - int keepLibrary, - const char *fullFileName, - int interpExiting -) -{ - int code; - InterpLibrary *ipFirstPtr, *ipPtr; - LoadedLibrary *iterLibraryPtr; - int trustedRefCount = -1, safeRefCount = -1; - Tcl_LibraryUnloadProc *unloadProc = NULL; - /* * Ensure that the DLL can be unloaded. If it is a trusted interpreter, - * libraryPtr->unloadProc must not be NULL for the DLL to be unloadable. If - * the interpreter is a safe one, libraryPtr->safeUnloadProc must be non-NULL. + * 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 (libraryPtr->safeUnloadProc == NULL) { - if (!interpExiting) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" cannot be unloaded under a safe interpreter", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - (void *)NULL); - code = TCL_ERROR; - goto done; - } + if (pkgPtr->safeUnloadProc == NULL) { + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded under a safe interpreter", NULL); + code = TCL_ERROR; + goto done; } - unloadProc = libraryPtr->safeUnloadProc; + unloadProc = pkgPtr->safeUnloadProc; } else { - if (libraryPtr->unloadProc == NULL) { - if (!interpExiting) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" cannot be unloaded under a trusted interpreter", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", - (void *)NULL); - code = TCL_ERROR; - goto done; - } + if (pkgPtr->unloadProc == NULL) { + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" cannot be unloaded under a trusted interpreter", NULL); + code = TCL_ERROR; + goto done; } - unloadProc = libraryPtr->unloadProc; + unloadProc = pkgPtr->unloadProc; } - - /* - * We are ready to unload the library. First, evaluate the unload + * 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 @@ -843,101 +725,68 @@ UnloadLibrary( * after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed. */ - if (unloadProc == NULL) { - code = TCL_OK; - } else { - code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; - if (!keepLibrary) { - Tcl_MutexLock(&libraryMutex); - trustedRefCount = libraryPtr->interpRefCount; - safeRefCount = libraryPtr->safeInterpRefCount; - Tcl_MutexUnlock(&libraryMutex); - - if (Tcl_IsSafe(target)) { - safeRefCount--; - } else { - trustedRefCount--; - } + code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; + if (!keepLibrary) { + Tcl_MutexLock(&packageMutex); + trustedRefCount = pkgPtr->interpRefCount; + safeRefCount = pkgPtr->safeInterpRefCount; + Tcl_MutexUnlock(&packageMutex); - if (safeRefCount <= 0 && trustedRefCount <= 0) { - code = TCL_UNLOAD_DETACH_FROM_PROCESS; - } + if (Tcl_IsSafe(target)) { + --safeRefCount; + } else { + --trustedRefCount; } - code = unloadProc(target, code); - } - - if (code != TCL_OK) { - Tcl_TransferResult(target, code, interp); - goto done; - } - - - /* - * Remove this library from the interpreter's library cache. - */ - - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = ipFirstPtr; - if (ipPtr->libraryPtr == libraryPtr) { - ipFirstPtr = ipFirstPtr->nextPtr; - } else { - InterpLibrary *ipPrevPtr; - - for (ipPrevPtr = ipPtr; ipPtr != NULL; - ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) { - if (ipPtr->libraryPtr == libraryPtr) { - ipPrevPtr->nextPtr = ipPtr->nextPtr; - break; - } + if (safeRefCount <= 0 && trustedRefCount <= 0) { + code = TCL_UNLOAD_DETACH_FROM_PROCESS; } } - ckfree(ipPtr); - Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); - - - if (IsStatic(libraryPtr)) { + code = (*unloadProc)(target, code); + if (code != TCL_OK) { + TclTransferResult(target, code, interp); goto done; } /* - * The unload function was called succesfully. + * The unload function executed fine. Examine the reference count to see + * if we unload the DLL. */ - Tcl_MutexLock(&libraryMutex); + Tcl_MutexLock(&packageMutex); if (Tcl_IsSafe(target)) { - libraryPtr->safeInterpRefCount--; + --pkgPtr->safeInterpRefCount; /* * Do not let counter get negative. */ - if (libraryPtr->safeInterpRefCount < 0) { - libraryPtr->safeInterpRefCount = 0; + if (pkgPtr->safeInterpRefCount < 0) { + pkgPtr->safeInterpRefCount = 0; } } else { - libraryPtr->interpRefCount--; + --pkgPtr->interpRefCount; /* * Do not let counter get negative. */ - if (libraryPtr->interpRefCount < 0) { - libraryPtr->interpRefCount = 0; + if (pkgPtr->interpRefCount < 0) { + pkgPtr->interpRefCount = 0; } } - trustedRefCount = libraryPtr->interpRefCount; - safeRefCount = libraryPtr->safeInterpRefCount; - Tcl_MutexUnlock(&libraryMutex); + trustedRefCount = pkgPtr->interpRefCount; + safeRefCount = pkgPtr->safeInterpRefCount; + Tcl_MutexUnlock(&packageMutex); code = TCL_OK; - if (libraryPtr->safeInterpRefCount <= 0 && libraryPtr->interpRefCount <= 0 - && (unloadProc != NULL) && !keepLibrary) { + if (pkgPtr->safeInterpRefCount <= 0 && pkgPtr->interpRefCount <= 0 + && !keepLibrary) { /* * Unload the shared library from the application memory... */ -#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) +#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 @@ -945,165 +794,231 @@ UnloadLibrary( * it's been unloaded. */ - if (!IsStatic(libraryPtr)) { - Tcl_MutexLock(&libraryMutex); - if (Tcl_FSUnloadFile(interp, libraryPtr->loadHandle) == TCL_OK) { + 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. */ - iterLibraryPtr = libraryPtr; - if (iterLibraryPtr == firstLibraryPtr) { - firstLibraryPtr = libraryPtr->nextPtr; + defaultPtr = pkgPtr; + if (defaultPtr == firstPackagePtr) { + firstPackagePtr = pkgPtr->nextPtr; } else { - for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; - libraryPtr = libraryPtr->nextPtr) { - if (libraryPtr->nextPtr == iterLibraryPtr) { - libraryPtr->nextPtr = iterLibraryPtr->nextPtr; + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; + pkgPtr = pkgPtr->nextPtr) { + if (pkgPtr->nextPtr == defaultPtr) { + pkgPtr->nextPtr = defaultPtr->nextPtr; break; } } } - ckfree(iterLibraryPtr->fileName); - ckfree(iterLibraryPtr->prefix); - ckfree(iterLibraryPtr); - Tcl_MutexUnlock(&libraryMutex); + /* + * 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_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" cannot be unloaded: unloading disabled", - fullFileName)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", - NULL); + 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; } /* *---------------------------------------------------------------------- * - * Tcl_StaticLibrary -- + * Tcl_StaticPackage -- * - * This function is invoked to indicate that a particular library has + * This function is invoked to indicate that a particular package has * been linked statically with an application. * * Results: * None. * * Side effects: - * Once this function completes, the library becomes loadable via the + * Once this function completes, the package becomes loadable via the * "load" command with an empty file name. * *---------------------------------------------------------------------- */ void -Tcl_StaticLibrary( - Tcl_Interp *interp, /* If not NULL, it means that the library has +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 *prefix, /* Prefix (must be properly + const char *pkgName, /* Name of package (must be properly * capitalized: first letter upper case, * others lower case). */ - Tcl_LibraryInitProc *initProc, + Tcl_PackageInitProc *initProc, /* Function to call to incorporate this - * library into a trusted interpreter. */ - Tcl_LibraryInitProc *safeInitProc) + * package into a trusted interpreter. */ + Tcl_PackageInitProc *safeInitProc) /* Function to call to incorporate this - * library into a safe interpreter (one that + * package into a safe interpreter (one that * will execute untrusted scripts). NULL means - * the library can't be used in safe + * the package can't be used in safe * interpreters. */ { - LoadedLibrary *libraryPtr; - InterpLibrary *ipPtr, *ipFirstPtr; + LoadedPackage *pkgPtr; + InterpPackage *ipPtr, *ipFirstPtr; /* - * Check to see if someone else has already reported this library as + * Check to see if someone else has already reported this package as * statically loaded in the process. */ - Tcl_MutexLock(&libraryMutex); - for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; libraryPtr = libraryPtr->nextPtr) { - if ((libraryPtr->initProc == initProc) - && (libraryPtr->safeInitProc == safeInitProc) - && (strcmp(libraryPtr->prefix, prefix) == 0)) { + Tcl_MutexLock(&packageMutex); + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + if ((pkgPtr->initProc == initProc) + && (pkgPtr->safeInitProc == safeInitProc) + && (strcmp(pkgPtr->packageName, pkgName) == 0)) { break; } } - Tcl_MutexUnlock(&libraryMutex); + Tcl_MutexUnlock(&packageMutex); /* - * If the library is not yet recorded as being loaded statically, add it + * If the package is not yet recorded as being loaded statically, add it * to the list now. */ - if (libraryPtr == NULL) { - libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary)); - libraryPtr->fileName = (char *)ckalloc(1); - libraryPtr->fileName[0] = 0; - libraryPtr->prefix = (char *)ckalloc(strlen(prefix) + 1); - strcpy(libraryPtr->prefix, prefix); - libraryPtr->loadHandle = NULL; - libraryPtr->initProc = initProc; - libraryPtr->safeInitProc = safeInitProc; - libraryPtr->unloadProc = NULL; - libraryPtr->safeUnloadProc = NULL; - Tcl_MutexLock(&libraryMutex); - libraryPtr->nextPtr = firstLibraryPtr; - firstLibraryPtr = libraryPtr; - Tcl_MutexUnlock(&libraryMutex); + 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)); + strcpy(pkgPtr->packageName, pkgName); + pkgPtr->loadHandle = NULL; + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + Tcl_MutexLock(&packageMutex); + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + Tcl_MutexUnlock(&packageMutex); } if (interp != NULL) { /* - * If we're loading the library into an interpreter, determine whether + * If we're loading the package into an interpreter, determine whether * it's already loaded. */ - ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL); - for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - if (ipPtr->libraryPtr == libraryPtr) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, + "tclLoad", NULL); + for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) { + if ( ipPtr->pkgPtr == pkgPtr ) { return; } } /* - * Library isn't loaded in the current interp yet. Mark it as now being + * Package isn't loade in the current interp yet. Mark it as now being * loaded. */ - ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary)); - ipPtr->libraryPtr = libraryPtr; + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; - Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); + Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); } } /* *---------------------------------------------------------------------- * - * TclGetLoadedLibraries -- + * TclGetLoadedPackages -- * * This function returns information about all of the files that are - * loaded (either in a particular interpreter, or for all interpreters). + * 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 prefix of the library in that file. + * the second element is the name of the package in that file. * * Side effects: * None. @@ -1112,77 +1027,57 @@ Tcl_StaticLibrary( */ int -TclGetLoadedLibraries( +TclGetLoadedPackages( Tcl_Interp *interp, /* Interpreter in which to return information * or error message. */ - const char *targetName, /* Name of target interpreter or NULL. If + char *targetName) /* Name of target interpreter or NULL. If * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ - const char *prefix) /* Prefix or NULL. If NULL, return info - * for all prefixes. - */ { Tcl_Interp *target; - LoadedLibrary *libraryPtr; - InterpLibrary *ipPtr; - Tcl_Obj *resultObj, *pkgDesc[2]; + LoadedPackage *pkgPtr; + InterpPackage *ipPtr; + const char *prefix; if (targetName == NULL) { - TclNewObj(resultObj); - Tcl_MutexLock(&libraryMutex); - for (libraryPtr = firstLibraryPtr; libraryPtr != NULL; - libraryPtr = libraryPtr->nextPtr) { - pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1); - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewListObj(2, pkgDesc)); - } - Tcl_MutexUnlock(&libraryMutex); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - } - - target = Tcl_GetChild(interp, targetName); - if (target == NULL) { - return TCL_ERROR; - } - ipPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); - - /* - * Return information about all of the available libraries. - */ - if (prefix) { - resultObj = NULL; - - for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - libraryPtr = ipPtr->libraryPtr; - - if (!strcmp(prefix, libraryPtr->prefix)) { - resultObj = Tcl_NewStringObj(libraryPtr->fileName, -1); - break; - } - } + /* + * Return information about all of the available packages. + */ - if (resultObj) { - Tcl_SetObjResult(interp, resultObj); + prefix = "{"; + Tcl_MutexLock(&packageMutex); + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; + pkgPtr = pkgPtr->nextPtr) { + Tcl_AppendResult(interp, prefix, NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", NULL); + prefix = " {"; } + Tcl_MutexUnlock(&packageMutex); return TCL_OK; } /* - * Return information about only the libraries that are loaded in a given + * Return information about only the packages that are loaded in a given * interpreter. */ - TclNewObj(resultObj); - for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { - libraryPtr = ipPtr->libraryPtr; - pkgDesc[0] = Tcl_NewStringObj(libraryPtr->fileName, -1); - pkgDesc[1] = Tcl_NewStringObj(libraryPtr->prefix, -1); - Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); + target = Tcl_GetSlave(interp, targetName); + if (target == NULL) { + return TCL_ERROR; + } + ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", NULL); + prefix = "{"; + for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + Tcl_AppendResult(interp, prefix, NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", NULL); + prefix = " {"; } - Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1191,7 +1086,7 @@ TclGetLoadedLibraries( * * LoadCleanupProc -- * - * This function is called to delete all of the InterpLibrary structures + * 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. * @@ -1199,27 +1094,24 @@ TclGetLoadedLibraries( * None. * * Side effects: - * Storage for all of the InterpLibrary functions for interp get deleted. + * Storage for all of the InterpPackage functions for interp get deleted. * *---------------------------------------------------------------------- */ static void LoadCleanupProc( - TCL_UNUSED(ClientData), /* Pointer to first InterpLibrary structure + ClientData clientData, /* Pointer to first InterpPackage structure * for interp. */ - Tcl_Interp *interp) + Tcl_Interp *interp) /* Interpreter that is being deleted. */ { - InterpLibrary *ipPtr; - LoadedLibrary *libraryPtr; + InterpPackage *ipPtr, *nextPtr; - while (1) { - ipPtr = (InterpLibrary *)Tcl_GetAssocData(interp, "tclLoad", NULL); - if (ipPtr == NULL) { - break; - } - libraryPtr = ipPtr->libraryPtr; - UnloadLibrary(interp, interp, libraryPtr, 0 ,"", 1); + ipPtr = (InterpPackage *) clientData; + while (ipPtr != NULL) { + nextPtr = ipPtr->nextPtr; + ckfree((char *) ipPtr); + ipPtr = nextPtr; } } @@ -1229,7 +1121,7 @@ LoadCleanupProc( * TclFinalizeLoad -- * * This function is invoked just before the application exits. It frees - * all of the LoadedLibrary structures. + * all of the LoadedPackage structures. * * Results: * None. @@ -1243,20 +1135,20 @@ LoadCleanupProc( void TclFinalizeLoad(void) { - LoadedLibrary *libraryPtr; + LoadedPackage *pkgPtr; /* * No synchronization here because there should just be one thread alive - * at this point. Logically, libraryMutex 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. + * 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 (firstLibraryPtr != NULL) { - libraryPtr = firstLibraryPtr; - firstLibraryPtr = libraryPtr->nextPtr; + while (firstPackagePtr != NULL) { + pkgPtr = firstPackagePtr; + firstPackagePtr = pkgPtr->nextPtr; -#if defined(TCL_UNLOAD_DLLS) || defined(_WIN32) +#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 @@ -1264,14 +1156,19 @@ TclFinalizeLoad(void) * it has been unloaded. */ - if (!IsStatic(libraryPtr)) { - Tcl_FSUnloadFile(NULL, libraryPtr->loadHandle); + if (pkgPtr->fileName[0] != '\0') { + Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; + if ((unLoadProcPtr != NULL) + && ((pkgPtr->unloadProc != NULL) + || (unLoadProcPtr == TclFSUnloadTempFile))) { + (*unLoadProcPtr)(pkgPtr->loadHandle); + } } #endif - ckfree(libraryPtr->fileName); - ckfree(libraryPtr->prefix); - ckfree(libraryPtr); + ckfree(pkgPtr->fileName); + ckfree(pkgPtr->packageName); + ckfree((char *) pkgPtr); } } |