diff options
author | stanton <stanton@noemail.net> | 1999-04-16 00:46:29 (GMT) |
---|---|---|
committer | stanton <stanton@noemail.net> | 1999-04-16 00:46:29 (GMT) |
commit | 98569293dc21e22480004e4e3f2ce85ec0bfd80f (patch) | |
tree | ce9959f2747257d98d52ec8d18bf3b0de99b9535 /generic/tclLoad.c | |
parent | 6a4a1d8213f4de5bce0eaafa8f4d86117022bf1a (diff) | |
download | tcl-98569293dc21e22480004e4e3f2ce85ec0bfd80f.zip tcl-98569293dc21e22480004e4e3f2ce85ec0bfd80f.tar.gz tcl-98569293dc21e22480004e4e3f2ce85ec0bfd80f.tar.bz2 |
merged tcl 8.1 branch back into the main trunk
FossilOrigin-Name: f3b32fb71c9011ac220779bd9dbe5617c9dc87d9
Diffstat (limited to 'generic/tclLoad.c')
-rw-r--r-- | generic/tclLoad.c | 253 |
1 files changed, 136 insertions, 117 deletions
diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 055dcee..68a0f8c 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. * - * RCS: @(#) $Id: tclLoad.c,v 1.2 1998/09/14 18:40:00 stanton Exp $ + * RCS: @(#) $Id: tclLoad.c,v 1.3 1999/04/16 00:46:50 stanton Exp $ */ #include "tclInt.h" @@ -17,7 +17,7 @@ /* * 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_PackageLoaded). All such packages + * indicated by a call to TclGetLoadedPackages). All such packages * are linked together into a single list for the process. Packages * are never unloaded, so these structures are never freed. */ @@ -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_THREADS + * 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 @@ -74,12 +86,11 @@ typedef struct InterpPackage { static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); -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 +105,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 +156,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 +174,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 +213,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 +246,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 +256,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 +282,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 +305,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 +321,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; } @@ -324,20 +347,20 @@ 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 +383,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 +402,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 +411,7 @@ Tcl_LoadCmd(dummy, interp, argc, argv) Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&fileName); + Tcl_DStringFree(&tmp); return code; } @@ -456,27 +460,31 @@ 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 +508,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 +540,7 @@ TclGetLoadedPackages(interp, targetName) */ prefix = "{"; + Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { Tcl_AppendResult(interp, prefix, (char *) NULL); @@ -540,6 +549,7 @@ TclGetLoadedPackages(interp, targetName) Tcl_AppendResult(interp, "}", (char *) NULL); prefix = " {"; } + Tcl_MutexUnlock(&packageMutex); return TCL_OK; } @@ -550,8 +560,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", @@ -606,7 +614,7 @@ LoadCleanupProc(clientData, interp) /* *---------------------------------------------------------------------- * - * LoadExitProc -- + * TclFinalizeLoad -- * * This procedure is invoked just before the application exits. * It frees all of the LoadedPackage structures. @@ -620,15 +628,26 @@ LoadCleanupProc(clientData, interp) *---------------------------------------------------------------------- */ -static void -LoadExitProc(clientData) - ClientData clientData; /* Not used. */ +void +TclFinalizeLoad() { LoadedPackage *pkgPtr; + /* + * No synchronization here because there should just be + * one thread alive at this point. Logically, + * packageMutex should be grabbed at this point, but + * the Mutexes get finalized before the call to this routine. + * The only subsystem left alive at this point is the + * memory allocator. + */ + 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); |