merged tcl 8.1 branch back into the main trunk

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);