summaryrefslogtreecommitdiffstats
path: root/generic/tclLoad.c
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /generic/tclLoad.c
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'generic/tclLoad.c')
-rw-r--r--generic/tclLoad.c253
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);