diff options
Diffstat (limited to 'generic/tclLoad.c')
| -rw-r--r-- | generic/tclLoad.c | 566 |
1 files changed, 284 insertions, 282 deletions
diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 72c33d4..7c70e03 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -8,8 +8,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclLoad.c,v 1.14 2005/07/17 21:17:43 dkf Exp $ */ #include "tclInt.h" @@ -17,8 +15,8 @@ /* * 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 + * 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. */ @@ -33,35 +31,30 @@ typedef struct LoadedPackage { * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file - * is no longer needed. If fileName is NULL, + * is no longer needed. If fileName is NULL, * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; - /* Initialization procedure to call to + /* Initialization function to call to * incorporate this package into a trusted * interpreter. */ Tcl_PackageInitProc *safeInitProc; - /* Initialization procedure to call to + /* Initialization function to call to * incorporate this package into a safe * interpreter (one that will execute * untrusted scripts). NULL means the package * can't be used in unsafe interpreters. */ Tcl_PackageUnloadProc *unloadProc; - /* Finalisation procedure to unload a package + /* Finalisation function to unload a package * from a trusted interpreter. NULL means that * the package cannot be unloaded. */ Tcl_PackageUnloadProc *safeUnloadProc; - /* Finalisation procedure to unload a package + /* Finalisation function to unload a package * from a safe interpreter. NULL means that * the package cannot be unloaded. */ int interpRefCount; /* How many times the package has been loaded * in trusted interpreters. */ int safeInterpRefCount; /* How many times the package has been loaded * in safe interpreters. */ - Tcl_FSUnloadFileProc *unLoadProcPtr; - /* Procedure to use to unload this package. - * If NULL, then we do not attempt to unload - * the package. If fileName is NULL, then - * this field is irrelevant. */ struct LoadedPackage *nextPtr; /* Next in list of all packages loaded into * this application process. NULL means end of @@ -83,7 +76,7 @@ TCL_DECLARE_MUTEX(packageMutex) /* * The following structure represents a particular package that has been * incorporated into a particular interpreter (by calling its initialization - * procedure). There is a list of these structures for each interpreter, with + * 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). */ @@ -97,18 +90,18 @@ typedef struct InterpPackage { } InterpPackage; /* - * Prototypes for procedures that are private to this file: + * Prototypes for functions that are private to this file: */ -static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp)); +static void LoadCleanupProc(ClientData clientData, + Tcl_Interp *interp); /* *---------------------------------------------------------------------- * * Tcl_LoadObjCmd -- * - * This procedure is invoked to process the "load" Tcl command. See the + * This function is invoked to process the "load" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -121,29 +114,52 @@ static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, */ int -Tcl_LoadObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_LoadObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; Tcl_DString pkgName, tmp, initName, safeInitName; Tcl_DString unloadName, safeUnloadName; - Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc; InterpPackage *ipFirstPtr, *ipPtr; int code, namesMatch, filesMatch, offset; - CONST char *symbols[4]; - Tcl_PackageInitProc **procPtrs[4]; - ClientData clientData; - char *p, *fullFileName, *packageName; + const char *symbols[2]; + Tcl_PackageInitProc *initProc; + const char *p, *fullFileName, *packageName; Tcl_LoadHandle loadHandle; - Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; Tcl_UniChar ch; + unsigned len; + int index, flags = 0; + Tcl_Obj *const *savedobjv = objv; + static const char *const options[] = { + "-global", "-lazy", "--", NULL + }; + enum options { + LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST + }; + 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 options) index) { + flags |= TCL_LOAD_GLOBAL; + } else if (LOAD_LAZY == (enum options) index) { + flags |= TCL_LOAD_LAZY; + } else { + break; + } + } if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { @@ -166,9 +182,10 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) } } if ((fullFileName[0] == 0) && (packageName == NULL)) { - Tcl_SetResult(interp, - "must specify either file name or package name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must specify either file name or package name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY", + NULL); code = TCL_ERROR; goto done; } @@ -179,7 +196,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) target = interp; if (objc == 4) { - char *slaveIntName = Tcl_GetString(objv[3]); + const char *slaveIntName = Tcl_GetString(objv[3]); target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { @@ -190,7 +207,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) /* * 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 + * 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. @@ -205,9 +222,9 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) if (packageName == NULL) { namesMatch = 0; } else { - Tcl_DStringSetLength(&pkgName, 0); + TclDStringClear(&pkgName); Tcl_DStringAppend(&pkgName, packageName, -1); - Tcl_DStringSetLength(&tmp, 0); + TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); @@ -218,7 +235,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) namesMatch = 0; } } - Tcl_DStringSetLength(&pkgName, 0); + TclDStringClear(&pkgName); filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); if (filesMatch && (namesMatch || (packageName == NULL))) { @@ -232,9 +249,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) * Can't have two different packages loaded from the same file. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" is already loaded for package \"", - pkgPtr->packageName, "\"", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" is already loaded for package \"%s\"", + fullFileName, pkgPtr->packageName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", + "SPLITPERSONALITY", NULL); code = TCL_ERROR; Tcl_MutexUnlock(&packageMutex); goto done; @@ -247,13 +266,12 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) /* * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, then + * interpreter. If the package we want is already loaded there, then * there's nothing for us to do. */ if (pkgPtr != NULL) { - ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", - (Tcl_InterpDeleteProc **) NULL); + ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->pkgPtr == pkgPtr) { code = TCL_OK; @@ -269,8 +287,10 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) */ if (fullFileName[0] == 0) { - Tcl_AppendResult(interp, "package \"", packageName, - "\" isn't loaded statically", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package \"%s\" isn't loaded statically", packageName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC", + NULL); code = TCL_ERROR; goto done; } @@ -290,10 +310,9 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) retc = TclGuessPackageName(fullFileName, &pkgName); if (!retc) { - Tcl_Obj *splitPtr; - Tcl_Obj *pkgGuessPtr; + Tcl_Obj *splitPtr, *pkgGuessPtr; int pElements; - char *pkgGuess; + const char *pkgGuess; /* * The platform-specific code couldn't figure out the module @@ -310,6 +329,12 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) && (pkgGuess[2] == 'b')) { pkgGuess += 3; } +#ifdef __CYGWIN__ + if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y') + && (pkgGuess[2] == 'g')) { + pkgGuess += 3; + } +#endif /* __CYGWIN__ */ for (p = pkgGuess; *p != 0; p += offset) { offset = Tcl_UtfToUniChar(p, &ch); if ((ch > 0x100) @@ -320,13 +345,15 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) } if (p == pkgGuess) { Tcl_DecrRefCount(splitPtr); - Tcl_AppendResult(interp, - "couldn't figure out package name for ", - fullFileName, (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't figure out package name for %s", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", + "WHATPACKAGE", NULL); code = TCL_ERROR; goto done; } - Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); + Tcl_DStringAppend(&pkgName, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); } } @@ -341,69 +368,57 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); /* - * Compute the names of the two initialization procedures, based on - * the package name. + * Compute the names of the two initialization functions, based on the + * package name. */ - Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); - Tcl_DStringAppend(&initName, "_Init", 5); - Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); - Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); - Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1); - Tcl_DStringAppend(&unloadName, "_Unload", 7); - Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1); - Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11); + TclDStringAppendDString(&initName, &pkgName); + TclDStringAppendLiteral(&initName, "_Init"); + TclDStringAppendDString(&safeInitName, &pkgName); + TclDStringAppendLiteral(&safeInitName, "_SafeInit"); + TclDStringAppendDString(&unloadName, &pkgName); + TclDStringAppendLiteral(&unloadName, "_Unload"); + TclDStringAppendDString(&safeUnloadName, &pkgName); + TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); /* * Call platform-specific code to load the package and find the two - * initialization procedures. + * initialization functions. */ symbols[0] = Tcl_DStringValue(&initName); - symbols[1] = Tcl_DStringValue(&safeInitName); - symbols[2] = Tcl_DStringValue(&unloadName); - symbols[3] = Tcl_DStringValue(&safeUnloadName); - procPtrs[0] = &initProc; - procPtrs[1] = &safeInitProc; - procPtrs[2] = &unloadProc; - procPtrs[3] = &safeUnloadProc; + symbols[1] = NULL; Tcl_MutexLock(&packageMutex); - code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs, - &loadHandle, &clientData, &unLoadProcPtr); + code = Tcl_LoadFile(interp, objv[1], symbols, flags, &initProc, + &loadHandle); Tcl_MutexUnlock(&packageMutex); - loadHandle = (Tcl_LoadHandle) clientData; if (code != TCL_OK) { goto done; } - if (*procPtrs[0] /* 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 = (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 = 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->unLoadProcPtr = unLoadProcPtr; - pkgPtr->initProc = *procPtrs[0]; - pkgPtr->safeInitProc = *procPtrs[1]; - pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2]; - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3]; + 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; @@ -411,60 +426,79 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) 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 procedure (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 (pkgPtr->safeInitProc != NULL) { - code = (*pkgPtr->safeInitProc)(target); - } else { - Tcl_AppendResult(interp, - "can't use package in a safe interpreter: no ", - pkgPtr->packageName, "_SafeInit procedure", (char *) NULL); + if (pkgPtr->safeInitProc == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't use package in a safe interpreter: no" + " %s_SafeInit procedure", pkgPtr->packageName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE", + NULL); code = TCL_ERROR; goto done; } + code = pkgPtr->safeInitProc(target); } else { - code = (*pkgPtr->initProc)(target); + if (pkgPtr->initProc == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't attach package to interpreter: no %s_Init procedure", + pkgPtr->packageName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", + NULL); + code = TCL_ERROR; + goto done; + } + code = pkgPtr->initProc(target); } /* - * Record the fact that the package has been loaded in the target - * interpreter. + * Test for whether the initialization failed. If so, transfer the error + * from the target interpreter to the originating one. */ - if (code == TCL_OK) { - /* - * Update the proper reference count. - */ - - Tcl_MutexLock(&packageMutex); - if (Tcl_IsSafe(target)) { - ++pkgPtr->safeInterpRefCount; - } else { - ++pkgPtr->interpRefCount; - } - Tcl_MutexUnlock(&packageMutex); + if (code != TCL_OK) { + Tcl_TransferResult(target, code, interp); + goto done; + } - /* - * Refetch ipFirstPtr: loading the package may have introduced - * additional static packages at the head of the linked list! - */ + /* + * Record the fact that the package has been loaded in the target + * interpreter. + * + * Update the proper reference count. + */ - 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); + Tcl_MutexLock(&packageMutex); + if (Tcl_IsSafe(target)) { + pkgPtr->safeInterpRefCount++; } else { - TclTransferResult(target, code, interp); + 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); @@ -481,8 +515,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) * * Tcl_UnloadObjCmd -- * - * This procedure is invoked to process the "unload" Tcl command. See - * the user documentation for details on what it does. + * 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. @@ -494,11 +528,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) */ int -Tcl_UnloadObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_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; @@ -507,8 +541,9 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) InterpPackage *ipFirstPtr, *ipPtr; int i, index, code, complain = 1, keepLibrary = 0; int trustedRefCount = -1, safeRefCount = -1; - char *fullFileName = "", *packageName; - static CONST char *options[] = { + const char *fullFileName = ""; + const char *packageName; + static const char *const options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; enum options { @@ -551,7 +586,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, - "?switches? fileName ?packageName? ?interp?"); + "?-switch ...? fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { @@ -570,9 +605,10 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) } } if ((fullFileName[0] == 0) && (packageName == NULL)) { - Tcl_SetResult(interp, - "must specify either file name or package name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must specify either file name or package name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY", + NULL); code = TCL_ERROR; goto done; } @@ -583,8 +619,8 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) target = interp; if (objc - i == 3) { - char *slaveIntName; - slaveIntName = Tcl_GetString(objv[i+2]); + const char *slaveIntName = Tcl_GetString(objv[i + 2]); + target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { return TCL_ERROR; @@ -593,7 +629,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) /* * 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 + * 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. @@ -610,9 +646,9 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) if (packageName == NULL) { namesMatch = 0; } else { - Tcl_DStringSetLength(&pkgName, 0); + TclDStringClear(&pkgName); Tcl_DStringAppend(&pkgName, packageName, -1); - Tcl_DStringSetLength(&tmp, 0); + TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); Tcl_UtfToLower(Tcl_DStringValue(&tmp)); @@ -623,7 +659,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) namesMatch = 0; } } - Tcl_DStringSetLength(&pkgName, 0); + TclDStringClear(&pkgName); filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); if (filesMatch && (namesMatch || (packageName == NULL))) { @@ -642,9 +678,11 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) * It's an error to try unload a static package. */ - Tcl_AppendResult(interp, "package \"", packageName, - "\" is loaded statically and cannot be unloaded", - (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package \"%s\" is loaded statically and cannot be unloaded", + packageName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC", + NULL); code = TCL_ERROR; goto done; } @@ -653,22 +691,23 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) * The DLL pointed by the provided filename has never been loaded. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" has never been loaded", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" has never been loaded", fullFileName)); + 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 + * interpreter. If the package we want is already loaded there, then we * should proceed with unloading. */ code = TCL_ERROR; if (pkgPtr != NULL) { - ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", - (Tcl_InterpDeleteProc **) NULL); + ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL); for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { if (ipPtr->pkgPtr == pkgPtr) { code = TCL_OK; @@ -681,8 +720,11 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) * The package has not been loaded in this interpreter. */ - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" has never been loaded in this interpreter", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" has never been loaded in this interpreter", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED", + NULL); code = TCL_ERROR; goto done; } @@ -695,18 +737,22 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) if (Tcl_IsSafe(target)) { if (pkgPtr->safeUnloadProc == NULL) { - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded under a safe interpreter", - (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a safe interpreter", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); code = TCL_ERROR; goto done; } unloadProc = pkgPtr->safeUnloadProc; } else { if (pkgPtr->unloadProc == NULL) { - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded under a trusted interpreter", - (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded under a trusted interpreter", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT", + NULL); code = TCL_ERROR; goto done; } @@ -715,7 +761,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) /* * We are ready to unload the package. First, evaluate the unload - * procedure. If this fails, we cannot proceed with unload. Also, we must + * 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 @@ -731,29 +777,29 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) Tcl_MutexUnlock(&packageMutex); if (Tcl_IsSafe(target)) { - --safeRefCount; + safeRefCount--; } else { - --trustedRefCount; + trustedRefCount--; } if (safeRefCount <= 0 && trustedRefCount <= 0) { code = TCL_UNLOAD_DETACH_FROM_PROCESS; } } - code = (*unloadProc)(target, code); + code = unloadProc(target, code); if (code != TCL_OK) { - TclTransferResult(target, code, interp); + Tcl_TransferResult(target, code, interp); goto done; } /* - * The unload procedure executed fine. Examine the reference count to see + * The unload function executed fine. Examine the reference count to see * if we unload the DLL. */ Tcl_MutexLock(&packageMutex); if (Tcl_IsSafe(target)) { - --pkgPtr->safeInterpRefCount; + pkgPtr->safeInterpRefCount--; /* * Do not let counter get negative. @@ -763,7 +809,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) pkgPtr->safeInterpRefCount = 0; } } else { - --pkgPtr->interpRefCount; + pkgPtr->interpRefCount--; /* * Do not let counter get negative. @@ -784,7 +830,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) * 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 @@ -793,12 +839,8 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) */ if (pkgPtr->fileName[0] != '\0') { - Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; - - if (unLoadProcPtr != NULL) { - Tcl_MutexLock(&packageMutex); - (*unLoadProcPtr)(pkgPtr->loadHandle); - + Tcl_MutexLock(&packageMutex); + if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) { /* * Remove this library from the loaded library cache. */ @@ -820,8 +862,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) * Remove this library from the interpreter's library cache. */ - ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, - "tclLoad", (Tcl_InterpDeleteProc **) NULL); + ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL); ipPtr = ipFirstPtr; if (ipPtr->pkgPtr == defaultPtr) { ipFirstPtr = ipFirstPtr->nextPtr; @@ -837,22 +878,22 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) } } Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, - (ClientData) ipFirstPtr); + ipFirstPtr); ckfree(defaultPtr->fileName); ckfree(defaultPtr->packageName); - ckfree((char *) defaultPtr); - ckfree((char *) ipPtr); + ckfree(defaultPtr); + ckfree(ipPtr); Tcl_MutexUnlock(&packageMutex); } else { - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded: filesystem does not support unloading", - (char *) NULL); code = TCL_ERROR; } } #else - Tcl_AppendResult(interp, "file \"", fullFileName, - "\" cannot be unloaded: unloading disabled", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file \"%s\" cannot be unloaded: unloading disabled", + fullFileName)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED", + NULL); code = TCL_ERROR; #endif } @@ -860,40 +901,10 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&tmp); - if (!complain && code!=TCL_OK) { + 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; } @@ -902,33 +913,33 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) * * Tcl_StaticPackage -- * - * This procedure is invoked to indicate that a particular package has + * This function is invoked to indicate that a particular package has * been linked statically with an application. * * Results: * None. * * Side effects: - * Once this procedure completes, the package becomes loadable via the + * Once this function completes, the package becomes loadable via the * "load" command with an empty file name. * *---------------------------------------------------------------------- */ void -Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) - Tcl_Interp *interp; /* If not NULL, it means that the package has +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 + 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 + Tcl_PackageInitProc *initProc, + /* Function to call to incorporate this * package into a trusted interpreter. */ - Tcl_PackageInitProc *safeInitProc; - /* Procedure to call to incorporate this + 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 @@ -957,12 +968,11 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * to the list now. */ - if ( pkgPtr == NULL ) { - pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *) ckalloc((unsigned) 1); + if (pkgPtr == NULL) { + pkgPtr = ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = ckalloc(1); pkgPtr->fileName[0] = 0; - pkgPtr->packageName = (char *) ckalloc((unsigned) - (strlen(pkgName) + 1)); + pkgPtr->packageName = ckalloc(strlen(pkgName) + 1); strcpy(pkgPtr->packageName, pkgName); pkgPtr->loadHandle = NULL; pkgPtr->initProc = initProc; @@ -980,10 +990,9 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * it's already loaded. */ - ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", - (Tcl_InterpDeleteProc **) NULL); - for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) { - if ( ipPtr->pkgPtr == pkgPtr ) { + ipFirstPtr = Tcl_GetAssocData(interp, "tclLoad", NULL); + for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->pkgPtr == pkgPtr) { return; } } @@ -993,11 +1002,10 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * loaded. */ - ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr = ckalloc(sizeof(InterpPackage)); ipPtr->pkgPtr = pkgPtr; ipPtr->nextPtr = ipFirstPtr; - Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, - (ClientData) ipPtr); + Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); } } @@ -1006,7 +1014,7 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * * TclGetLoadedPackages -- * - * This procedure returns information about all of the files that are + * This function returns information about all of the files that are * loaded (either in a particular intepreter, or for all interpreters). * * Results: @@ -1023,10 +1031,10 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) */ int -TclGetLoadedPackages(interp, targetName) - Tcl_Interp *interp; /* Interpreter in which to return information +TclGetLoadedPackages( + Tcl_Interp *interp, /* Interpreter in which to return information * or error message. */ - char *targetName; /* Name of target interpreter or NULL. If + const char *targetName) /* Name of target interpreter or NULL. If * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ @@ -1034,24 +1042,24 @@ TclGetLoadedPackages(interp, targetName) Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; - char *prefix; + Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { /* * Return information about all of the available packages. */ - prefix = "{"; + resultObj = Tcl_NewObj(); Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - Tcl_AppendResult(interp, prefix, (char *) NULL); - Tcl_AppendElement(interp, pkgPtr->fileName); - Tcl_AppendElement(interp, pkgPtr->packageName); - Tcl_AppendResult(interp, "}", (char *) NULL); - prefix = " {"; + pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + Tcl_ListObjAppendElement(NULL, resultObj, + Tcl_NewListObj(2, pkgDesc)); } Tcl_MutexUnlock(&packageMutex); + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1064,17 +1072,15 @@ TclGetLoadedPackages(interp, targetName) if (target == NULL) { return TCL_ERROR; } - ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", - (Tcl_InterpDeleteProc **) NULL); - prefix = "{"; - for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL); + resultObj = Tcl_NewObj(); + for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; - Tcl_AppendResult(interp, prefix, (char *) NULL); - Tcl_AppendElement(interp, pkgPtr->fileName); - Tcl_AppendElement(interp, pkgPtr->packageName); - Tcl_AppendResult(interp, "}", (char *) NULL); - prefix = " {"; + pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1); + pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1); + Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc)); } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } @@ -1083,7 +1089,7 @@ TclGetLoadedPackages(interp, targetName) * * LoadCleanupProc -- * - * This procedure is called to delete all of the InterpPackage 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. * @@ -1091,24 +1097,23 @@ TclGetLoadedPackages(interp, targetName) * None. * * Side effects: - * Storage for all of the InterpPackage procedures for interp get - * deleted. + * Storage for all of the InterpPackage functions for interp get deleted. * *---------------------------------------------------------------------- */ static void -LoadCleanupProc(clientData, interp) - ClientData clientData; /* Pointer to first InterpPackage structure +LoadCleanupProc( + ClientData clientData, /* Pointer to first InterpPackage structure * for interp. */ - Tcl_Interp *interp; /* Interpreter that is being deleted. */ + Tcl_Interp *interp) /* Interpreter that is being deleted. */ { InterpPackage *ipPtr, *nextPtr; - ipPtr = (InterpPackage *) clientData; + ipPtr = clientData; while (ipPtr != NULL) { nextPtr = ipPtr->nextPtr; - ckfree((char *) ipPtr); + ckfree(ipPtr); ipPtr = nextPtr; } } @@ -1118,7 +1123,7 @@ LoadCleanupProc(clientData, interp) * * TclFinalizeLoad -- * - * This procedure is invoked just before the application exits. It frees + * This function is invoked just before the application exits. It frees * all of the LoadedPackage structures. * * Results: @@ -1131,40 +1136,37 @@ LoadCleanupProc(clientData, interp) */ void -TclFinalizeLoad() +TclFinalizeLoad(void) { LoadedPackage *pkgPtr; /* * No synchronization here because there should just be one thread alive * at this point. Logically, packageMutex should be grabbed at this point, - * but the Mutexes get finalized before the call to this routine. The - * only subsystem left alive at this point is the memory allocator. + * 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__) +#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. + * it has been unloaded. */ if (pkgPtr->fileName[0] != '\0') { - Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; - if (unLoadProcPtr != NULL) { - (*unLoadProcPtr)(pkgPtr->loadHandle); - } + Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle); } #endif ckfree(pkgPtr->fileName); ckfree(pkgPtr->packageName); - ckfree((char *) pkgPtr); + ckfree(pkgPtr); } } |