diff options
Diffstat (limited to 'generic/tclLoad.c')
-rw-r--r-- | generic/tclLoad.c | 232 |
1 files changed, 125 insertions, 107 deletions
diff --git a/generic/tclLoad.c b/generic/tclLoad.c index a1deee0..bcea456 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -4,12 +4,12 @@ * This file provides the generic portion (those that are the same * on all platforms) of Tcl's dynamic loading facilities. * - * Copyright (c) 1995 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. * - * SCCS: @(#) tclLoad.c 1.17 97/07/24 20:05:04 + * SCCS: @(#) tclLoad.c 1.30 98/02/19 13:51:49 */ #include "tclInt.h" @@ -31,6 +31,10 @@ typedef struct LoadedPackage { * properly capitalized (first letter UC, * others LC), no "_", as in "Net". * Malloc-ed. */ + ClientData clientData; /* Token for the loaded file which should be + * passed to TclpUnloadFile() when the file + * is no longer needed. If fileName is NULL, + * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; /* Initialization procedure to call to * incorporate this package into a trusted @@ -48,10 +52,18 @@ typedef struct LoadedPackage { * end of list. */ } LoadedPackage; +/* + * TCL_THREAD + * There is a global list of packages that is anchored at firstPackagePtr. + * Access to this list is governed by a mutex. + */ + static LoadedPackage *firstPackagePtr = NULL; /* First in list of all packages loaded into * this process. */ +TCL_DECLARE_MUTEX(packageMutex) + /* * The following structure represents a particular package that has * been incorporated into a particular interpreter (by calling its @@ -79,7 +91,7 @@ static void LoadExitProc _ANSI_ARGS_((ClientData clientData)); /* *---------------------------------------------------------------------- * - * Tcl_LoadCmd -- + * Tcl_LoadObjCmd -- * * This procedure is invoked to process the "load" Tcl command. * See the user documentation for details on what it does. @@ -94,38 +106,45 @@ static void LoadExitProc _ANSI_ARGS_((ClientData clientData)); */ int -Tcl_LoadCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +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, initName, safeInitName, fileName; + Tcl_DString pkgName, tmp, initName, safeInitName, fileName; Tcl_PackageInitProc *initProc, *safeInitProc; InterpPackage *ipFirstPtr, *ipPtr; - int code, c, gotPkgName, namesMatch, filesMatch; - char *p, *fullFileName, *p1, *p2; - - if ((argc < 2) || (argc > 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " fileName ?packageName? ?interp?\"", (char *) NULL); + int code, namesMatch, filesMatch; + char *p, *tempString, *fullFileName, *packageName; + ClientData clientData; + Tcl_UniChar ch; + int offset; + + if ((objc < 2) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } - fullFileName = Tcl_TranslateFileName(interp, argv[1], &fileName); + tempString = Tcl_GetString(objv[1]); + fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName); if (fullFileName == NULL) { return TCL_ERROR; } Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); - if ((argc >= 3) && (argv[2][0] != 0)) { - gotPkgName = 1; - } else { - gotPkgName = 0; + Tcl_DStringInit(&tmp); + + packageName = NULL; + if (objc >= 3) { + packageName = Tcl_GetString(objv[2]); + if (packageName[0] == '\0') { + packageName = NULL; + } } - if ((fullFileName[0] == 0) && !gotPkgName) { + if ((fullFileName[0] == 0) && (packageName == NULL)) { Tcl_SetResult(interp, "must specify either file name or package name", TCL_STATIC); @@ -138,11 +157,11 @@ Tcl_LoadCmd(dummy, interp, argc, argv) */ target = interp; - if (argc == 4) { - target = Tcl_GetSlave(interp, argv[3]); + if (objc == 4) { + char *slaveIntName; + slaveIntName = Tcl_GetString(objv[3]); + target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { - Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", - argv[3], "\"", (char *) NULL); return TCL_ERROR; } } @@ -156,26 +175,30 @@ Tcl_LoadCmd(dummy, interp, argc, argv) * - 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) { - if (!gotPkgName) { + if (packageName == NULL) { namesMatch = 0; } else { - namesMatch = 1; - for (p1 = argv[2], p2 = pkgPtr->packageName; ; p1++, p2++) { - if ((isupper(UCHAR(*p1)) ? tolower(UCHAR(*p1)) : *p1) - != (isupper(UCHAR(*p2)) ? tolower(UCHAR(*p2)) : *p2)) { - namesMatch = 0; - break; - } - if (*p1 == 0) { - break; - } + 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 || !gotPkgName)) { + if (filesMatch && (namesMatch || (packageName == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { @@ -191,9 +214,11 @@ Tcl_LoadCmd(dummy, interp, argc, argv) "\" is already loaded for package \"", pkgPtr->packageName, "\"", (char *) NULL); code = TCL_ERROR; + Tcl_MutexUnlock(&packageMutex); goto done; } } + Tcl_MutexUnlock(&packageMutex); if (pkgPtr == NULL) { pkgPtr = defaultPtr; } @@ -222,7 +247,7 @@ Tcl_LoadCmd(dummy, interp, argc, argv) */ if (fullFileName[0] == 0) { - Tcl_AppendResult(interp, "package \"", argv[2], + Tcl_AppendResult(interp, "package \"", packageName, "\" isn't loaded statically", (char *) NULL); code = TCL_ERROR; goto done; @@ -232,10 +257,15 @@ Tcl_LoadCmd(dummy, interp, argc, argv) * Figure out the module name if it wasn't provided explicitly. */ - if (gotPkgName) { - Tcl_DStringAppend(&pkgName, argv[2], -1); + if (packageName != NULL) { + Tcl_DStringAppend(&pkgName, packageName, -1); } else { - if (!TclGuessPackageName(fullFileName, &pkgName)) { + int retc; + /* + * Threading note - this call used to be protected by a mutex. + */ + retc = TclGuessPackageName(fullFileName, &pkgName); + if (!retc) { int pargc; char **pargv, *pkgGuess; @@ -253,8 +283,13 @@ Tcl_LoadCmd(dummy, interp, argc, argv) && (pkgGuess[2] == 'b')) { pkgGuess += 3; } - for (p = pkgGuess; isalpha(UCHAR(*p)) || (*p == '_'); p++) { - /* Empty loop body. */ + 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) { ckfree((char *)pargv); @@ -271,27 +306,12 @@ Tcl_LoadCmd(dummy, interp, argc, argv) /* * Fix the capitalization in the package name so that the first - * character is in caps but the others are all lower-case. + * character is in caps (or title case) but the others are all + * lower-case. */ - p = Tcl_DStringValue(&pkgName); - c = UCHAR(*p); - if (c != 0) { - if (islower(c)) { - *p = (char) toupper(c); - } - p++; - while (1) { - c = UCHAR(*p); - if (c == 0) { - break; - } - if (isupper(c)) { - *p = (char) tolower(c); - } - p++; - } - } + Tcl_DStringSetLength(&pkgName, + Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); /* * Compute the names of the two initialization procedures, @@ -302,20 +322,24 @@ Tcl_LoadCmd(dummy, interp, argc, argv) Tcl_DStringAppend(&initName, "_Init", 5); Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); - + /* * Call platform-specific code to load the package and find the * two initialization procedures. */ - - code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), - Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc); + + Tcl_MutexLock(&packageMutex); + code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), + Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc, + &clientData); + Tcl_MutexUnlock(&packageMutex); if (code != TCL_OK) { goto done; } - if (initProc == NULL) { + if (initProc == NULL) { Tcl_AppendResult(interp, "couldn't find procedure ", Tcl_DStringValue(&initName), (char *) NULL); + TclpUnloadFile(clientData); code = TCL_ERROR; goto done; } @@ -323,21 +347,23 @@ Tcl_LoadCmd(dummy, interp, argc, argv) /* * Create a new record to describe this package. */ - if (firstPackagePtr == NULL) { Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); } pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *) ckalloc((unsigned) + pkgPtr->fileName = (char *) ckalloc((unsigned) (strlen(fullFileName) + 1)); strcpy(pkgPtr->fileName, fullFileName); - pkgPtr->packageName = (char *) ckalloc((unsigned) + pkgPtr->packageName = (char *) ckalloc((unsigned) (Tcl_DStringLength(&pkgName) + 1)); strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = safeInitProc; - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; + pkgPtr->clientData = clientData; + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + Tcl_MutexLock(&packageMutex); + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + Tcl_MutexUnlock(&packageMutex); } /* @@ -360,28 +386,6 @@ Tcl_LoadCmd(dummy, interp, argc, argv) } else { code = (*pkgPtr->initProc)(target); } - if ((code == TCL_ERROR) && (target != interp)) { - /* - * An error occurred, so transfer error information from the - * destination interpreter back to our interpreter. Must clear - * interp's result before calling Tcl_AddErrorInfo, since - * Tcl_AddErrorInfo will store the interp's result in errorInfo - * before appending target's $errorInfo; we've already got - * everything we need in target's $errorInfo. - */ - - /* - * It is (abusively) assumed that errorInfo and errorCode vars exists. - * we changed SetVar2 to accept NULL values to avoid crashes. --dl - */ - Tcl_ResetResult(interp); - Tcl_AddErrorInfo(interp, Tcl_GetVar2(target, - "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(target, "errorCode", (char *) NULL, - TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); - Tcl_SetResult(interp, target->result, TCL_VOLATILE); - } /* * Record the fact that the package has been loaded in the @@ -401,6 +405,8 @@ Tcl_LoadCmd(dummy, interp, argc, argv) ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, (ClientData) ipPtr); + } else { + TclTransferResult(target, code, interp); } done: @@ -408,6 +414,7 @@ Tcl_LoadCmd(dummy, interp, argc, argv) Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&fileName); + Tcl_DStringFree(&tmp); return code; } @@ -456,27 +463,33 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * statically loaded. If this call is redundant then just return. */ + Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { if ((pkgPtr->initProc == initProc) && (pkgPtr->safeInitProc == safeInitProc) && (strcmp(pkgPtr->packageName, pkgName) == 0)) { + Tcl_MutexUnlock(&packageMutex); return; } } - if (firstPackagePtr == NULL) { Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); } + Tcl_MutexUnlock(&packageMutex); + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *) ckalloc((unsigned) 1); - pkgPtr->fileName[0] = 0; - pkgPtr->packageName = (char *) ckalloc((unsigned) + pkgPtr->fileName = (char *) ckalloc((unsigned) 1); + pkgPtr->fileName[0] = 0; + pkgPtr->packageName = (char *) ckalloc((unsigned) (strlen(pkgName) + 1)); strcpy(pkgPtr->packageName, pkgName); - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = safeInitProc; - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; + pkgPtr->clientData = NULL; + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + Tcl_MutexLock(&packageMutex); + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + Tcl_MutexUnlock(&packageMutex); if (interp != NULL) { ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", @@ -500,7 +513,7 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * * Results: * The return value is a standard Tcl completion code. If - * successful, a list of lists is placed in interp->result. + * 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 @@ -532,6 +545,7 @@ TclGetLoadedPackages(interp, targetName) */ prefix = "{"; + Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { Tcl_AppendResult(interp, prefix, (char *) NULL); @@ -540,6 +554,7 @@ TclGetLoadedPackages(interp, targetName) Tcl_AppendResult(interp, "}", (char *) NULL); prefix = " {"; } + Tcl_MutexUnlock(&packageMutex); return TCL_OK; } @@ -550,8 +565,6 @@ TclGetLoadedPackages(interp, targetName) target = Tcl_GetSlave(interp, targetName); if (target == NULL) { - Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", - targetName, "\"", (char *) NULL); return TCL_ERROR; } ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", @@ -626,11 +639,16 @@ LoadExitProc(clientData) { LoadedPackage *pkgPtr; + Tcl_MutexLock(&packageMutex); while (firstPackagePtr != NULL) { pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; + if (pkgPtr->fileName[0] != '\0') { + TclpUnloadFile(pkgPtr->clientData); + } ckfree(pkgPtr->fileName); ckfree(pkgPtr->packageName); ckfree((char *) pkgPtr); } + Tcl_MutexUnlock(&packageMutex); } |