diff options
Diffstat (limited to 'tests/load.test')
| -rw-r--r-- | tests/load.test | 255 |
1 files changed, 255 insertions, 0 deletions
diff --git a/tests/load.test b/tests/load.test new file mode 100644 index 0000000..4cd1fcd --- /dev/null +++ b/tests/load.test @@ -0,0 +1,255 @@ +# Commands covered: load +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[lsearch [namespace children] ::tcltest] == -1} { + 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 {![info exists ext]} { + set ext [info sharedlibextension] +} +# Tests require the existence of one of the DLLs in the dltest directory. +set testDir [file join [file dirname [info nameofexecutable]] dltest] +set x [file join $testDir pkga$ext] +set dll "[file tail $x]Required" +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] +testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}] + +set alreadyTotalLoaded [info 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 ?-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 ?-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 [catch {load -global {}} msg] $msg +} {1 {must specify either file name or package name}} +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 [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 -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 -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} -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}} + +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 +} {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" + invoked from within +"if 44 {open non_existent}" + invoked from within +"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} +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 result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ + $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 + while executing +"open non_existent" + invoked from within +"if 44 {open non_existent}" + invoked from within +"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 +} {0 {}} +test load-4.2 {reloading package into same interpreter} -setup { + catch {load [file join $testDir pkga$ext] pkga} +} -constraints [list $dll $loaded] -returnCodes error -body { + load [file join $testDir pkga$ext] pkgb +} -result "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 -global [file join $testDir pkga$ext] pkga + load {} pkga x + set result [info loaded x] + interp delete x + set result +} [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] { + catch {load foo foo} +} {1} + +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} +catch {load [file join $testDir pkga$ext] pkga} +catch {load [file join $testDir pkgb$ext] pkgb} +catch {load [file join $testDir pkge$ext] pkge} +set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] +test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup { + teststaticpkg Test 1 0 + teststaticpkg Another 0 0 + teststaticpkg More 0 1 +} -constraints [list teststaticpkg $dll $loaded] -body { + teststaticpkg Double 0 1 + teststaticpkg Double 0 1 + info loaded +} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] + +testConstraint teststaticpkg_8.x \ + [if {[testConstraint teststaticpkg]} { + teststaticpkg Test 1 1 + teststaticpkg Another 0 1 + teststaticpkg More 0 1 + teststaticpkg Double 0 1 + expr 1 + } else { + expr 0 + }] + +test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + lsort -index 1 [info loaded] +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] +test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { + info loaded gorp +} -returnCodes error -result {could not find interpreter "gorp"} +test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + lsort -index 1 [info loaded {}] +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] +test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + lsort -index 1 [info loaded child] +} [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] +test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + load [file join $testDir pkgb$ext] pkgb + list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] +} [list [lsort -index 1 [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: |