? load.patch
? solaris
? unix/httpd
Index: doc/StaticPkg.3
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/StaticPkg.3,v
retrieving revision 1.3
diff -u -r1.3 StaticPkg.3
--- doc/StaticPkg.3	2000/04/14 23:01:54	1.3
+++ doc/StaticPkg.3	2001/01/31 22:47:43
@@ -24,8 +24,8 @@
 appropriate initialization procedure).  NULL means the package
 hasn't yet been incorporated into any interpreter.
 .AP char *pkgName in
-Name of the package;  should be properly capitalized (first letter
-upper-case, all others lower-case).
+Name of the package.  Should be the same string as passed
+by \fIinitProc\fR and \fIsafeInitProc\fR to \fBTcl_PkgProvide\fR.
 .AP Tcl_PackageInitProc *initProc in
 Procedure to invoke to incorporate this package into a trusted
 interpreter.
@@ -42,6 +42,23 @@
 has already been loaded into an interpreter.
 Once \fBTcl_StaticPackage\fR has been invoked for a package, it
 may be loaded into interpreters using the \fBload\fR command.
+.PP
+If \fIinterp\fR is not NULL, \fBTcl_StaticPackage\fR will check
+that package \fIpkgName\fR has been provided in \fIinterp\fR.
+If package \fIpkgName\fR has not been provided in \fIinterp\fR,
+\fBTcl_StaticPackage\fR will do nothing.  When used properly,
+a call to one of the initialization procedures, either
+.CS
+(*initProc)(\fIinterp\fR)
+.CE
+or
+.CS
+(*safeInitProc)(\fIinterp\fR)
+.CE
+should precede the call to \fBTcl_StaticPackage\fR.  Then package
+\fIpkgName\fR will be provided in \fIinterp\fR, and
+\fBTcl_StaticPackage\fR will do its work.
+.PP
 \fBTcl_StaticPackage\fR is normally invoked only by the \fBTcl_AppInit\fR
 procedure for the application, not by packages for themselves
 (\fBTcl_StaticPackage\fR should only be invoked for statically
@@ -59,11 +76,13 @@
 .CE
 The \fIinterp\fR argument identifies the interpreter in which the package
 is to be loaded.  The initialization procedure must return \fBTCL_OK\fR or
-\fBTCL_ERROR\fR to indicate whether or not it completed successfully; in
+\fBTCL_ERROR\fR to indicate whether or not it completed successfully.  In
 the event of an error it should set the interpreter's result to point to an
-error message.  The result or error from the initialization procedure will
-be returned as the result of the \fBload\fR command that caused the
-initialization procedure to be invoked.
+error message, which will be returned as the result of the \fBload\fR
+command that caused the initialization procedure to be invoked.  If
+the initialization procedure completes successfully, it must provide
+the package \fIpkgName\fR.  If it fails to do so, an error message
+reporting that failure will be returned as the result of \fBload\fR.
 
 .SH KEYWORDS
 initialization procedure, package, static linking
Index: doc/info.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/info.n,v
retrieving revision 1.5
diff -u -r1.5 info.n
--- doc/info.n	2000/09/07 14:27:48	1.5
+++ doc/info.n	2001/01/31 22:47:43
@@ -110,10 +110,11 @@
 .TP
 \fBinfo loaded \fR?\fIinterp\fR?
 Returns a list describing all of the packages that have been loaded into
-\fIinterp\fR with the \fBload\fR command.
+\fIinterp\fR with the \fBload\fR command, and all statically-loaded
+packages initialized in \fIinterp\fR by \fBTcl_StaticPackage\fR.
 Each list element is a sub-list with two elements consisting of the
 name of the file from which the package was loaded and the name of
-the package.
+the package provided when that file was loaded.
 For statically-loaded packages the file name will be an empty string.
 If \fIinterp\fR is omitted then information is returned for all packages
 loaded in any interpreter in the process.
Index: doc/load.n
===================================================================
RCS file: /cvsroot/tcl/tcl/doc/load.n,v
retrieving revision 1.6
diff -u -r1.6 load.n
--- doc/load.n	2000/09/07 14:27:49	1.6
+++ doc/load.n	2001/01/31 22:47:43
@@ -61,12 +61,16 @@
 .CS
 typedef int Tcl_PackageInitProc(Tcl_Interp *\fIinterp\fR);
 .CE
-The \fIinterp\fR argument identifies the interpreter in which the
-package is to be loaded.  The initialization procedure must return
-\fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed
-successfully;  in the event of an error it should set the interpreter's result
-to point to an error message.  The result of the \fBload\fR command
-will be the result returned by the initialization procedure.
+The \fIinterp\fR argument identifies the interpreter in which the package
+is to be loaded.  The initialization procedure must return \fBTCL_OK\fR or
+\fBTCL_ERROR\fR to indicate whether or not it completed successfully.  In
+the event of an error it should set the interpreter's result to point to an
+error message, which will be returned as the result of \fBload\fR.
+If the initialization procedure completes successfully, it must provide
+the package \fIpackageName\fR.  If it fails to do so, \fBload\fR will
+return an error message reporting that failure.  If the initialization
+procedure successfully provides the package \fIpackageName\fR in
+\fIinterp\fR, \fBload\fR returns an empty string.
 .PP
 The actual loading of a file will only be done once for each \fIfileName\fR
 in an application.  If a given \fIfileName\fR is loaded into multiple
@@ -88,11 +92,14 @@
 take the last element of \fIfileName\fR, strip off the first
 three characters if they are \fBlib\fR, and use any following
 .VS
-alphabetic and underline characters as the module name.
+alphabetic and underline characters to create the package name.
+Finally the extracted alphabetic and underline characters have
+their case converted in the same manner used to determine the
+name of the initialization procedure.
 .VE
-For example, the command \fBload libxyz4.2.so\fR uses the module
-name \fBxyz\fR and the command \fBload bin/last.so {}\fR uses the
-module name \fBlast\fR.
+For example, the command \fBload libxyz4.2.so\fR uses the package
+name \fBXyz\fR and the command \fBload bin/last.so {}\fR uses the
+package name \fBLast\fR.
 .VS "" br
 .PP
 If \fIfileName\fR is an empty string, then \fIpackageName\fR must
Index: generic/tclLoad.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclLoad.c,v
retrieving revision 1.4
diff -u -r1.4 tclLoad.c
--- generic/tclLoad.c	1999/12/01 00:08:28	1.4
+++ generic/tclLoad.c	2001/01/31 22:47:44
@@ -27,9 +27,7 @@
 				 * package was loaded.  An empty string
 				 * means the package is loaded statically.
 				 * Malloc-ed. */
-    char *packageName;		/* Name of package prefix for the package,
-				 * properly capitalized (first letter UC,
-				 * others LC), no "_", as in "Net". 
+    char *packageName;		/* Name of package.
 				 * Malloc-ed. */
     ClientData clientData;	/* Token for the loaded file which should be
 				 * passed to TclpUnloadFile() when the file
@@ -68,7 +66,7 @@
  * 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 an AssocData value (key "load") for the
+ * each interpreter, with an AssocData value (key "tclLoad") for the
  * interpreter that points to the first package (if any).
  */
 
@@ -161,7 +159,8 @@
 	slaveIntName = Tcl_GetString(objv[3]);
 	target = Tcl_GetSlave(interp, slaveIntName);
 	if (target == NULL) {
-	    return TCL_ERROR;
+	    code = TCL_ERROR;
+	    goto done;
 	}
     }
 
@@ -171,8 +170,12 @@
      * 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.
-     *  - Its name matches, the file name was specified as empty, and there
-     *    is only no statically loaded package with the same name.
+     *  - Its name matches, the file name was specified as empty, and the
+     *    loaded package was the first of all those loaded with the same
+     *    name.  Since statically loaded packages are loaded using
+     *    Tcl_StaticPackage() during application startup, a statically
+     *    loaded package is preferred over all dynamically loaded 
+     *    packages with the same name.
      */
     Tcl_MutexLock(&packageMutex);
 
@@ -185,8 +188,6 @@
 	    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;
@@ -300,26 +301,31 @@
 		}
 		Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess));
 		ckfree((char *)pargv);
+
+		/*
+		 * Normalize the guessed package name to have the
+		 * capitalization expected for the prefix of the
+		 * initialization procedures.
+		 */
+
+		Tcl_DStringSetLength(&pkgName,
+			Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));
 	    }
 	}
 
-	/*
-	 * Fix the capitalization in the package name so that the first
-	 * character is in caps (or title case) but the others are all
-	 * lower-case.
-	 */
-    
-	Tcl_DStringSetLength(&pkgName,
-		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 procedures.
+	 * The common prefix for the names of both initialization
+	 * procedures is derived from the package name by forcing
+	 * the first character to upper case and all other characters
+	 * to lower case.  The package name itself is not changed.
 	 */
     
 	Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1);
+	Tcl_DStringSetLength(&initName,
+		Tcl_UtfToTitle(Tcl_DStringValue(&initName)));
+	Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&initName), -1);
 	Tcl_DStringAppend(&initName, "_Init", 5);
-	Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
 	Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
 
 	/*
@@ -373,9 +379,13 @@
 	if (pkgPtr->safeInitProc != NULL) {
 	    code = (*pkgPtr->safeInitProc)(target);
 	} else {
+	    Tcl_DStringSetLength(&tmp, 0);
+	    Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
+	    Tcl_DStringSetLength(&tmp,
+		    Tcl_UtfToTitle(Tcl_DStringValue(&tmp)));
 	    Tcl_AppendResult(interp,
 		    "can't use package in a safe interpreter: ",
-		    "no ", pkgPtr->packageName, "_SafeInit procedure",
+		    "no ", Tcl_DStringValue(&tmp), "_SafeInit procedure",
 		    (char *) NULL);
 	    code = TCL_ERROR;
 	    goto done;
@@ -385,27 +395,53 @@
     }
 
     /*
-     * Record the fact that the package has been loaded in the
-     * target interpreter.
+     * If the initialization procedure failed, return the error
+     * message, and don't register the load in the target interp.
      */
-
-    if (code == TCL_OK) {
-	/*
-	 * Refetch ipFirstPtr: loading the package may have introduced
-	 * additional static packages at the head of the linked list!
-	 */
 
-	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);
-    } else {
+    if (code != TCL_OK) {
 	TclTransferResult(target, code, interp);
+	goto done;
+    }
+
+    /*
+     * If the initialization procedure did not provide the package we
+     * associate with loading the file, we want to report that as an
+     * error to the caller, and we want to not register that package
+     * as one loaded in target for later return by [info loaded target].
+     */
+
+    if ((Tcl_PkgPresent(target, pkgPtr->packageName, NULL, 0) == NULL) ) {
+	if (target == interp) {
+	    Tcl_ResetResult(interp);
+	}
+        Tcl_AppendResult(interp, "loading \"", fullFileName,
+		"\" did not provide package \"", pkgPtr->packageName, "\"",
+		(char *) NULL);
+	if (target != interp) {
+	    Tcl_AppendResult(interp, " in ", Tcl_GetString(objv[3]),
+		    (char *) NULL);
+	}
+        code = TCL_ERROR;
+        goto done;
     }
 
+    /*
+     * Record the fact that the package has been loaded in the
+     * target interpreter.
+     *
+     * Refetch ipFirstPtr: loading the package may have introduced
+     * additional static packages at the head of the linked list!
+     */
+
+    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);
+
     done:
     Tcl_DStringFree(&pkgName);
     Tcl_DStringFree(&initName);
@@ -439,9 +475,7 @@
 					 * package has already been loaded
 					 * into the given interpreter by
 					 * calling the appropriate init proc. */
-    char *pkgName;			/* Name of package (must be properly
-					 * capitalized: first letter upper
-					 * case, others lower case). */
+    char *pkgName;			/* Name of package */
     Tcl_PackageInitProc *initProc;	/* Procedure to call to incorporate
 					 * this package into a trusted
 					 * interpreter. */
@@ -454,6 +488,18 @@
 {
     LoadedPackage *pkgPtr;
     InterpPackage *ipPtr, *ipFirstPtr;
+
+    /*
+     * When used properly, Tcl_StaticPackage() should be called only
+     * after the appropriate init proc has been called to provide
+     * pkgName in interp.  If package pkgName has not been provided
+     * in interp, return immediately.  Do not register a false claim
+     * that package pkgName is loaded in interp.
+     */
+
+    if (interp != NULL && Tcl_PkgPresent(interp, pkgName, NULL, 0) == NULL) {
+	return;
+    }
 
     /*
      * Check to see if someone else has already reported this package as
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.22
diff -u -r1.22 tclTest.c
--- generic/tclTest.c	2000/11/24 11:27:37	1.22
+++ generic/tclTest.c	2001/01/31 22:47:44
@@ -49,6 +49,13 @@
 static Tcl_Interp *delInterp;
 
 /*
+ * Dynamic string shared by TeststaticpkgCmd and StaticInitProc; used
+ * to covertly pass the package name.
+ */
+
+static Tcl_DString packageName;
+
+/*
  * One of the following structures exists for each asynchronous
  * handler created by the "testasync" command".
  */
@@ -3053,6 +3060,11 @@
     if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) {
 	return TCL_ERROR;
     }
+    Tcl_DStringInit(&packageName);
+    Tcl_DStringAppend(&packageName, argv[1], -1);
+    if (loaded) {
+	StaticInitProc(interp);
+    }
     Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc,
 	    (safe) ? StaticInitProc : NULL);
     return TCL_OK;
@@ -3063,6 +3075,7 @@
     Tcl_Interp *interp;			/* Interpreter in which package
 					 * is supposedly being loaded. */
 {
+    Tcl_PkgProvide(interp, Tcl_DStringValue(&packageName), "0");
     Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY);
     return TCL_OK;
 }
Index: tests/load.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/load.test,v
retrieving revision 1.7
diff -u -r1.7 load.test
--- tests/load.test	2000/04/10 17:19:01	1.7
+++ tests/load.test	2001/01/31 22:47:44
@@ -66,9 +66,9 @@
     list [pkga_eq abc def] [info commands pkga_*]
 } {0 {pkga_eq pkga_quote}}
 interp create -safe child
-test load-2.2 {loading into a safe interpreter, with package name conversion} \
+test load-2.2 {loading into a safe interpreter, with explicit package name} \
 	[list $dll $loaded] {
-    load [file join $testDir pkgb$ext] pKgB child
+    load [file join $testDir pkgb$ext] Pkgb child
     list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
 	    [catch {pkgb_sub 12 10} msg2] $msg2
 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
@@ -109,22 +109,35 @@
 "load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}}
 
 test load-4.1 {reloading package into same interpreter} [list $dll $loaded] {
-    list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg
+    list [catch {load [file join $testDir pkga$ext] Pkga} msg] $msg
 } {0 {}}
 test load-4.2 {reloading package into same interpreter} [list $dll $loaded] {
     list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
 } "1 {file \"[file join $testDir pkga$ext\"] is already loaded for package \"Pkga\"}"
+test load-4.3 {reloading package into same interpreter} [list $dll $loaded] {
+    list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg
+} "1 {file \"[file join $testDir pkga$ext\"] is already loaded for package \"Pkga\"}"
 
 test load-5.1 {file name not specified and no static package: pick default} \
 	[list $dll $loaded] {
     catch {interp delete x}
     interp create x
-    load [file join $testDir pkga$ext] pkga
-    load {} pkga x
+    load [file join $testDir pkga$ext] Pkga
+    load {} Pkga x
     set result [info loaded x]
     interp delete x
     set result
 } "{[file join $testDir pkga$ext] Pkga}"
+test load-5.2 {file name not specified and no matching package} \
+	[list $dll $loaded] {
+    catch {interp delete x}
+    interp create x
+    load [file join $testDir pkga$ext] Pkga
+    set result [list [catch {load {} pkga x} msg] $msg]
+    lappend result [info loaded x]
+    interp delete x
+    set result
+} {1 {package "pkga" isn't loaded statically} {}}
 
 # On some platforms, like SunOS 4.1.3, these tests can't be run because
 # they cause the process to exit.
@@ -133,6 +146,13 @@
     catch {load foo foo}
 } {1}
 
+test load-6.2 {_Init procedure fails to provide package} {
+    list [catch {load [file join $testDir pkgd$ext] Pkgd} msg] $msg
+} "1 {loading \"[file join $testDir pkgd$ext]\" did not provide package \"Pkgd\"}"
+test load-6.3 {_SafeInit procedure fails to provide package} {
+    list [catch {load {} Pkgd child} msg] $msg
+} "1 {loading \"\" did not provide package \"Pkgd\" in child}"
+
 if {[info command teststaticpkg] != ""} {
     test load-7.1 {Tcl_StaticPackage procedure} [list $dll $loaded] {
 	set x "not loaded"
@@ -152,19 +172,21 @@
     test load-7.3 {Tcl_StaticPackage procedure} [list $dll $loaded] {
 	set x "not loaded"
 	teststaticpkg More 0 1
+	set result $x
+	set x "not loaded"
 	load {} More
-	set x
-    } {not loaded}
+	list $result $x
+    } {loaded {not loaded}}
     test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \
 	    [list $dll $loaded] {
 	teststaticpkg Double 0 1
 	teststaticpkg Double 0 1
-	info loaded
-    } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded"
+	info loaded {}
+    } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded"
 
     test load-8.1 {TclGetLoadedPackages procedure} [list $dll $loaded] {
 	info loaded
-    } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded"
+    } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkgd$ext] Pkgd} {[file join $testDir pkge$ext] pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} $alreadyTotalLoaded"
     test load-8.2 {TclGetLoadedPackages procedure} [list $dll $loaded] {
 	list [catch {info loaded gorp} msg] $msg
     } {1 {could not find interpreter "gorp"}}
@@ -172,7 +194,7 @@
 	list [info loaded {}] [info loaded child]
     } "{{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {{{} Test} {[file join $testDir pkgb$ext] Pkgb}}"
     test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded] {
-	load [file join $testDir pkgb$ext] pkgb
+	load [file join $testDir pkgb$ext] Pkgb
 	list [info loaded {}] [lsort [info commands pkgb_*]]
     } "{{[file join $testDir pkgb$ext] Pkgb} {{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} $alreadyLoaded} {pkgb_sub pkgb_unsafe}"
     interp delete child
Index: unix/dltest/pkgd.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/dltest/pkgd.c,v
retrieving revision 1.4
diff -u -r1.4 pkgd.c
--- unix/dltest/pkgd.c	2000/04/04 08:06:07	1.4
+++ unix/dltest/pkgd.c	2001/01/31 22:47:44
@@ -117,10 +117,15 @@
     if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) {
 	return TCL_ERROR;
     }
+/*
+ * We forget to provide the package "Pkgd"
+ *
     code = Tcl_PkgProvide(interp, "Pkgd", "7.3");
     if (code != TCL_OK) {
 	return code;
     }
+ *
+ */
     Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd,
 	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
     Tcl_CreateObjCommand(interp, "pkgd_unsafe", Pkgd_UnsafeObjCmd,
@@ -155,10 +160,15 @@
     if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) {
 	return TCL_ERROR;
     }
+/*
+ * We forget to provide the package "Pkgd"
+ *
     code = Tcl_PkgProvide(interp, "Pkgd", "7.3");
     if (code != TCL_OK) {
 	return code;
     }
+ *
+ */
     Tcl_CreateObjCommand(interp, "pkgd_sub", Pkgd_SubObjCmd, (ClientData) 0,
 	    (Tcl_CmdDeleteProc *) NULL);
     return TCL_OK;
