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