diff options
| -rw-r--r-- | ChangeLog | 10 | ||||
| -rw-r--r-- | generic/tclLoad.c | 58 | ||||
| -rw-r--r-- | tests/load.test | 133 |
3 files changed, 122 insertions, 79 deletions
@@ -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 - - - - - - - - - - - - |