summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog10
-rw-r--r--generic/tclLoad.c58
-rw-r--r--tests/load.test133
3 files changed, 122 insertions, 79 deletions
diff --git a/ChangeLog b/ChangeLog
index 3e9a770..78c17f0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,15 @@
2003-02-01 Kevin Kenny <kennykb@users.sourceforge.net>
+ * generic/tclLoad.c: Changed the code so that if Tcl_StaticPackage
+ is called to report the same package as being loaded in two interps,
+ it shows up in [info loaded {}] in both of them (previously,
+ it didn't appear in the static package list in the second.
+
+ * tests/load.test Added regression test for the above bug.
+ [Bug 670042]
+
+2003-02-01 Kevin Kenny <kennykb@users.sourceforge.net>
+
* generic/tclClock.c: Fixed a bug that incorrectly allowed
[clock clicks {}] and [clock clicks -] to be accepted as if
they were [clock clicks -milliseconds].
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 959fd7b..6773ac4 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -9,7 +9,7 @@
* 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.8 2002/07/22 16:51:48 vincentdarley Exp $
+ * RCS: @(#) $Id: tclLoad.c,v 1.9 2003/02/01 23:37:29 kennykb Exp $
*/
#include "tclInt.h"
@@ -469,7 +469,7 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
/*
* Check to see if someone else has already reported this package as
- * statically loaded. If this call is redundant then just return.
+ * statically loaded in the process.
*/
Tcl_MutexLock(&packageMutex);
@@ -477,30 +477,52 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
if ((pkgPtr->initProc == initProc)
&& (pkgPtr->safeInitProc == safeInitProc)
&& (strcmp(pkgPtr->packageName, pkgName) == 0)) {
- Tcl_MutexUnlock(&packageMutex);
- return;
+ break;
}
}
-
Tcl_MutexUnlock(&packageMutex);
- pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
- pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
- pkgPtr->fileName[0] = 0;
- pkgPtr->packageName = (char *) ckalloc((unsigned)
- (strlen(pkgName) + 1));
- strcpy(pkgPtr->packageName, pkgName);
- pkgPtr->loadHandle = NULL;
- pkgPtr->initProc = initProc;
- pkgPtr->safeInitProc = safeInitProc;
- Tcl_MutexLock(&packageMutex);
- pkgPtr->nextPtr = firstPackagePtr;
- firstPackagePtr = pkgPtr;
- Tcl_MutexUnlock(&packageMutex);
+ /*
+ * If the package is not yet recorded as being loaded statically,
+ * add it to the list now.
+ */
+
+ if ( pkgPtr == NULL ) {
+ pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
+ pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
+ pkgPtr->fileName[0] = 0;
+ pkgPtr->packageName = (char *) ckalloc((unsigned)
+ (strlen(pkgName) + 1));
+ strcpy(pkgPtr->packageName, pkgName);
+ pkgPtr->loadHandle = NULL;
+ pkgPtr->initProc = initProc;
+ pkgPtr->safeInitProc = safeInitProc;
+ Tcl_MutexLock(&packageMutex);
+ pkgPtr->nextPtr = firstPackagePtr;
+ firstPackagePtr = pkgPtr;
+ Tcl_MutexUnlock(&packageMutex);
+ }
if (interp != NULL) {
+
+ /*
+ * If we're loading the package into an interpreter,
+ * determine whether it's already loaded.
+ */
+
ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
(Tcl_InterpDeleteProc **) NULL);
+ for ( ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr ) {
+ if ( ipPtr->pkgPtr == pkgPtr ) {
+ return;
+ }
+ }
+
+ /*
+ * Package isn't loade in the current interp yet. Mark it as
+ * now being loaded.
+ */
+
ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
diff --git a/tests/load.test b/tests/load.test
index db2d073..bd480b9 100644
--- a/tests/load.test
+++ b/tests/load.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: load.test,v 1.10 2002/06/22 04:19:47 dgp Exp $
+# RCS: @(#) $Id: load.test,v 1.11 2003/02/01 23:37:29 kennykb Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -41,22 +41,28 @@ set alreadyLoaded [info loaded]
set alreadyTotalLoaded [info loaded]
-test load-1.1 {basic errors} [list $dll $loaded] {
+# Certain tests require the 'teststaticpkg' command from tcltest
+
+::tcltest::testConstraint teststaticpkg \
+ [string compare {} [info commands teststaticpkg]]
+
+
+test load-1.1 {basic errors} {} {
list [catch {load} msg] $msg
-} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}}
-test load-1.2 {basic errors} [list $dll $loaded] {
+} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
+test load-1.2 {basic errors} {} {
list [catch {load a b c d} msg] $msg
-} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}}
-test load-1.3 {basic errors} [list $dll $loaded] {
+} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
+test load-1.3 {basic errors} {} {
list [catch {load a b foobar} msg] $msg
} {1 {could not find interpreter "foobar"}}
-test load-1.4 {basic errors} [list $dll $loaded] {
+test load-1.4 {basic errors} {} {
list [catch {load {}} msg] $msg
} {1 {must specify either file name or package name}}
-test load-1.5 {basic errors} [list $dll $loaded] {
+test load-1.5 {basic errors} {} {
list [catch {load {} {}} msg] $msg
} {1 {must specify either file name or package name}}
-test load-1.6 {basic errors} [list $dll $loaded] {
+test load-1.6 {basic errors} {} {
list [catch {load {} Unknown} msg] $msg
} {1 {package "Unknown" isn't loaded statically}}
@@ -133,63 +139,68 @@ test load-6.1 {errors loading file} [list $dll $loaded nonPortable] {
catch {load foo foo}
} {1}
-if {[info command teststaticpkg] != ""} {
- test load-7.1 {Tcl_StaticPackage procedure} [list $dll $loaded] {
- set x "not loaded"
- teststaticpkg Test 1 0
- load {} Test
- load {} Test child
- list [set x] [child eval set x]
- } {loaded loaded}
- test load-7.2 {Tcl_StaticPackage procedure} [list $dll $loaded] {
- set x "not loaded"
- teststaticpkg Another 0 0
- load {} Another
- child eval {set x "not loaded"}
- list [catch {load {} Another child} msg] $msg \
- [child eval set x] [set x]
- } {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}
- test load-7.3 {Tcl_StaticPackage procedure} [list $dll $loaded] {
- set x "not loaded"
- teststaticpkg More 0 1
- load {} More
- set x
- } {not loaded}
- test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \
- [list $dll $loaded] {
+test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] {
+ set x "not loaded"
+ teststaticpkg Test 1 0
+ load {} Test
+ load {} Test child
+ list [set x] [child eval set x]
+} {loaded loaded}
+test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] {
+ set x "not loaded"
+ teststaticpkg Another 0 0
+ load {} Another
+ child eval {set x "not loaded"}
+ list [catch {load {} Another child} msg] $msg \
+ [child eval set x] [set x]
+} {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}
+test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] {
+ set x "not loaded"
+ teststaticpkg More 0 1
+ load {} More
+ set x
+} {not loaded}
+test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \
+ [list teststaticpkg $dll $loaded] {
teststaticpkg Double 0 1
teststaticpkg Double 0 1
info loaded
} [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded]
- test load-8.1 {TclGetLoadedPackages procedure} [list $dll $loaded] {
- info loaded
- } [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [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"}}
- test load-8.3 {TclGetLoadedPackages procedure} [list $dll $loaded] {
- list [info loaded {}] [info loaded child]
- } [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
- test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded] {
- load [file join $testDir pkgb$ext] pkgb
- list [info loaded {}] [lsort [info commands pkgb_*]]
- } [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_sub pkgb_unsafe}]
- interp delete child
-}
-
+test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
+ info loaded
+} [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded]
+test load-8.2 {TclGetLoadedPackages procedure} [list teststaticpkg] {
+ list [catch {info loaded gorp} msg] $msg
+} {1 {could not find interpreter "gorp"}}
+test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
+ list [info loaded {}] [info loaded child]
+} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
+test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
+ load [file join $testDir pkgb$ext] pkgb
+ list [info loaded {}] [lsort [info commands pkgb_*]]
+} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_sub pkgb_unsafe}]
+interp delete child
+
+test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \
+ -constraints {teststaticpkg} \
+ -setup {
+ interp create child1
+ interp create child2
+ load {} Tcltest child1
+ load {} Tcltest child2
+ } \
+ -body {
+ child1 eval { teststaticpkg Loadninepointone 0 1 }
+ child2 eval { teststaticpkg Loadninepointone 0 1 }
+ list \
+ [child1 eval { info loaded {} }] \
+ [child2 eval { info loaded {} }]
+ } \
+ -result {{{{} Loadninepointone} {{} Tcltest}} {{{} Loadninepointone} {{} Tcltest}}} \
+ -cleanup { interp delete child1 ; interp delete child2 }
+
+
# cleanup
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
generated by cgit v0.12 at 2024-11-05 08:36:26 (GMT)