258 lines
10 KiB
Plaintext
258 lines
10 KiB
Plaintext
|
# 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 Scriptics Corporation.
|
|||
|
|
#
|
|||
|
|
# See the file "license.terms" for information on usage and redistribution
|
|||
|
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|||
|
|
|
|||
|
|
if {"::tcltest" ni [namespace children]} {
|
|||
|
|
package require tcltest 2.5
|
|||
|
|
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} -returnCodes error -body {
|
|||
|
|
load
|
|||
|
|
} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"}
|
|||
|
|
test load-1.2 {basic errors} -returnCodes error -body {
|
|||
|
|
load a b c d
|
|||
|
|
} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"}
|
|||
|
|
test load-1.3 {basic errors} -returnCodes error -body {
|
|||
|
|
load a b foobar
|
|||
|
|
} -result {could not find interpreter "foobar"}
|
|||
|
|
test load-1.4 {basic errors} -returnCodes error -body {
|
|||
|
|
load -global {}
|
|||
|
|
} -result {must specify either file name or package name}
|
|||
|
|
test load-1.5 {basic errors} -returnCodes error -body {
|
|||
|
|
load -lazy {} {}
|
|||
|
|
} -result {must specify either file name or package name}
|
|||
|
|
test load-1.6 {basic errors} -returnCodes error -body {
|
|||
|
|
load {} Unknown
|
|||
|
|
} -result {package "Unknown" isn't loaded statically}
|
|||
|
|
test load-1.7 {basic errors} -returnCodes error -body {
|
|||
|
|
load -abc foo
|
|||
|
|
} -result {bad option "-abc": must be -global, -lazy, or --}
|
|||
|
|
test load-1.8 {basic errors} -returnCodes error -body {
|
|||
|
|
load -global
|
|||
|
|
} -result {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, child 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} -setup {
|
|||
|
|
catch {interp delete x}
|
|||
|
|
interp create x
|
|||
|
|
} -constraints [list $dll $loaded] -body {
|
|||
|
|
load -global [file join $testDir pkga$ext] Pkga
|
|||
|
|
load {} Pkga x
|
|||
|
|
info loaded x
|
|||
|
|
} -cleanup {
|
|||
|
|
interp delete x
|
|||
|
|
} -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 0
|
|||
|
|
if {[testConstraint teststaticpkg]} {
|
|||
|
|
catch {
|
|||
|
|
teststaticpkg Test 1 1
|
|||
|
|
teststaticpkg Another 0 1
|
|||
|
|
teststaticpkg More 0 1
|
|||
|
|
teststaticpkg Double 0 1
|
|||
|
|
testConstraint teststaticpkg_8.x 1
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
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} -setup {
|
|||
|
|
interp create child1
|
|||
|
|
interp create child2
|
|||
|
|
load {} Tcltest child1
|
|||
|
|
load {} Tcltest child2
|
|||
|
|
} -constraints {teststaticpkg} -body {
|
|||
|
|
child1 eval { teststaticpkg Loadninepointone 0 1 }
|
|||
|
|
child2 eval { teststaticpkg Loadninepointone 0 1 }
|
|||
|
|
list [child1 eval { info loaded {} }] \
|
|||
|
|
[child2 eval { info loaded {} }]
|
|||
|
|
} -match glob -cleanup {
|
|||
|
|
interp delete child1
|
|||
|
|
interp delete child2
|
|||
|
|
} -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}}
|
|||
|
|
|
|||
|
|
test load-10.1 {load from vfs} -setup {
|
|||
|
|
set dir [pwd]
|
|||
|
|
cd $testDir
|
|||
|
|
testsimplefilesystem 1
|
|||
|
|
} -constraints [list $dll $loaded testsimplefilesystem] -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:
|