diff options
Diffstat (limited to 'tests/load.test')
| -rw-r--r-- | tests/load.test | 218 |
1 files changed, 128 insertions, 90 deletions
diff --git a/tests/load.test b/tests/load.test index 8bbfb98..9536271 100644 --- a/tests/load.test +++ b/tests/load.test @@ -9,71 +9,85 @@ # # 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.4 1999/04/16 00:47:30 stanton Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - source [file join [pwd] [file dirname [info script]] defs.tcl] + package require tcltest 2 + namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Figure out what extension is used for shared libraries on this # platform. - -if {$tcl_platform(platform) == "macintosh"} { - puts "can't run dynamic library tests on macintosh machines" - ::tcltest::cleanupTests - return +if {![info exists ext]} { + set ext [info sharedlibextension] } - # Tests require the existence of one of the DLLs in the dltest directory. -set ext [info sharedlibextension] set testDir [file join [file dirname [info nameofexecutable]] dltest] set x [file join $testDir pkga$ext] set dll "[file tail $x]Required" -set ::tcltest::testConfig($dll) [file readable $x] +testConstraint $dll [file readable $x] # Tests also require that this DLL has not already been loaded. set loaded "[file tail $x]Loaded" set alreadyLoaded [info loaded] -set ::tcltest::testConfig($loaded) \ - [expr {![string match *pkga* $alreadyLoaded]}] +testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] -test load-1.1 {basic errors} [list $dll $loaded] { +# Certain tests require the 'teststaticpkg' command from tcltest + +testConstraint teststaticpkg [llength [info commands teststaticpkg]] + +# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest + +testConstraint testsimplefilesystem \ + [llength [info commands testsimplefilesystem]] + +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 ?-global? ?-lazy? ?--? 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 ?-global? ?-lazy? ?--? 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] { - list [catch {load {}} msg] $msg +test load-1.4 {basic errors} {} { + list [catch {load -global {}} msg] $msg } {1 {must specify either file name or package name}} -test load-1.5 {basic errors} [list $dll $loaded] { - list [catch {load {} {}} msg] $msg +test load-1.5 {basic errors} {} { + list [catch {load -lazy {} {}} 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}} +test load-1.7 {basic errors} {} { + list [catch {load -abc foo} msg] $msg +} "1 {bad option \"-abc\": must be -global, -lazy, or --}" +test load-1.8 {basic errors} {} { + list [catch {load -global} msg] $msg +} "1 {couldn't figure out package name for -global}" test load-2.1 {basic loading, with guess for package name} \ [list $dll $loaded] { - load [file join $testDir pkga$ext] - list [pkga_eq abc def] [info commands pkga_*] + load -global [file join $testDir pkga$ext] + list [pkga_eq abc def] [lsort [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} \ [list $dll $loaded] { - load [file join $testDir pkgb$ext] pKgB child + load -lazy [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"}} -test load-2.3 {loading with no _Init procedure} [list $dll $loaded] { - list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg -} {1 {couldn't find procedure Foo_Init}} +test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \ +-body { + list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode +} -match glob \ + -result [list 1 {cannot find symbol "Foo_Init"*} \ + {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg } {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}} @@ -81,7 +95,7 @@ test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { test load-3.1 {error in _Init procedure, same interpreter} \ [list $dll $loaded] { list [catch {load [file join $testDir pkge$ext] pkge} msg] \ - $msg $errorInfo $errorCode + $msg $::errorInfo $::errorCode } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory while executing "open non_existent" @@ -93,10 +107,10 @@ test load-3.2 {error in _Init procedure, slave interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x - set errorCode foo - set errorInfo bar + set ::errorCode foo + set ::errorInfo bar set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ - $msg $errorInfo $errorCode] + $msg $::errorInfo $::errorCode] interp delete x set result } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory @@ -112,83 +126,107 @@ test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { } {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\"}" +} [list 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 -global [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}" +} [list [list [file join $testDir pkga$ext] Pkga]] # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. +# +# As of 2005, such ancient broken systems no longer matter. -test load-6.1 {errors loading file} [list $dll $loaded nonPortable] { +test load-6.1 {errors loading file} [list $dll $loaded] { 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 - } "{{} Double} {{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[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" - 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] - } "{{{} 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 - 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 -} - + } [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 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_demo 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 {} }] + } \ + -match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \ + -cleanup { interp delete child1 ; interp delete child2 } + +test load-10.1 {load from vfs} \ + -constraints [list $dll $loaded testsimplefilesystem] \ + -setup {set dir [pwd]; cd $testDir; testsimplefilesystem 1} \ + -body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \ + -result {0 {}} \ + -cleanup {testsimplefilesystem 0; cd $dir; unset dir} + +test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ + [list $dll $loaded] { + load [file join $testDir pkgooa$ext] + list [pkgooa_stubsok] [lsort [info commands pkgooa_*]] +} {1 pkgooa_stubsok} + # cleanup +unset ext ::tcltest::cleanupTests return - - - - - - - - - - - +# Local Variables: +# mode: tcl +# End: |