diff options
Diffstat (limited to 'tests/load.test')
| -rw-r--r-- | tests/load.test | 160 |
1 files changed, 160 insertions, 0 deletions
diff --git a/tests/load.test b/tests/load.test new file mode 100644 index 0000000..5c33677 --- /dev/null +++ b/tests/load.test @@ -0,0 +1,160 @@ +# 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. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# SCCS: @(#) load.test 1.19 96/11/30 16:05:18 + +if {[string compare test [info procs test]] == 1} then {source defs} + +# 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" + return +} +set ext [info sharedlibextension] +set testDir [file join [file dirname [info nameofexecutable]] dltest] +if ![file readable [file join $testDir pkga$ext]] { + puts "libraries in $testDir haven't been compiled: skipping tests" + return +} + +if [string match *pkga* [set alreadyLoaded [info loaded {}]]] { + puts "load tests have already been run once: skipping (can't rerun)" + return +} + +set alreadyTotalLoaded [info loaded] + +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 [catch {load a b c d} msg] $msg +} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}} +test load-1.3 {basic errors} { + list [catch {load a b foobar} msg] $msg +} {1 {couldn't find slave interpreter named "foobar"}} +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 [catch {load {} {}} 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-2.1 {basic loading, with guess for package name} { + load [file join $testDir pkga$ext] + 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} { + 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"}} +test load-2.3 {loading with no _Init procedure} { + list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg +} {1 {couldn't find procedure Foo_Init}} +test load-2.4 {loading with no _SafeInit procedure} { + 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 [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 +"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} +test load-3.2 {error in _Init procedure, slave interpreter} { + 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 +"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 [catch {load [file join $testDir pkga$ext] pkga} msg] $msg +} {0 {}} +test load-4.2 {reloading package into same interpreter} { + 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-5.1 {file name not specified and no static package: pick default} { + catch {interp delete x} + interp create 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}" + +# On some platforms, like SunOS 4.1.3, these tests can't be run because +# they cause the process to exit. + +test load-6.1 {errors loading file} {nonPortable} { + catch {load foo foo} +} {1} + +if {[info command teststaticpkg] != ""} { + test load-7.1 {Tcl_StaticPackage procedure} { + 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} { + 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} { + set x "not loaded" + teststaticpkg More 0 1 + load {} More + set x + } {not loaded} + test load-7.4 {Tcl_StaticPackage procedure, redundant calls} { + 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} { + 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 [catch {info loaded gorp} msg] $msg + } {1 {couldn't find slave interpreter named "gorp"}} + test load-8.3 {TclGetLoadedPackages procedure} { + 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} { + 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 +} |