148 lines
6.0 KiB
Plaintext
148 lines
6.0 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.
|
|
#
|
|
# See the file "license.terms" for information on usage and redistribution
|
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
#
|
|
# SCCS: %Z% %M% %I% %E% %U%
|
|
|
|
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* [info loaded]] {
|
|
puts "load tests have already been run once: skipping (can't rerun)"
|
|
return
|
|
}
|
|
|
|
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
|
|
"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} {
|
|
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 [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\"}"
|
|
|
|
# On some platforms, like SunOS 4.1.3, these tests can't be run because
|
|
# they cause the process to exit.
|
|
|
|
test load-5.1 {errors loading file} {nonPortable} {
|
|
catch {load foo foo}
|
|
} {1}
|
|
|
|
if {[info command teststaticpkg] != ""} {
|
|
test load-6.1 {Tcl_StaticPackage procedure, static packages} {
|
|
set x "not loaded"
|
|
teststaticpkg Test 1 0
|
|
load {} Test
|
|
load {} Test child
|
|
list [set x] [child eval set x]
|
|
} {loaded loaded}
|
|
test load-6.2 {Tcl_StaticPackage procedure, static packages} {
|
|
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-6.3 {Tcl_StaticPackage procedure, static packages} {
|
|
set x "not loaded"
|
|
teststaticpkg More 0 1
|
|
load {} More
|
|
set x
|
|
} {not loaded}
|
|
|
|
test load-7.1 {TclGetLoadedPackages procedure} {
|
|
info loaded
|
|
} "{{} More} {{} Another} {{} Test} {[file join $testDir pkge$ext] Pkge} {[file join $testDir pkgb$ext] Pkgb} {[file join $testDir pkga$ext] Pkga} {{} Tcltest}"
|
|
test load-7.2 {TclGetLoadedPackages procedure} {
|
|
list [catch {info loaded gorp} msg] $msg
|
|
} {1 {couldn't find slave interpreter named "gorp"}}
|
|
test load-7.3 {TclGetLoadedPackages procedure} {
|
|
list [info loaded {}] [info loaded child]
|
|
} "{{{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} {{} Tcltest}} {{{} Test} {[file join $testDir pkgb$ext] Pkgb}}"
|
|
test load-7.4 {TclGetLoadedPackages procedure} {
|
|
load [file join $testDir pkgb$ext] pkgb
|
|
list [info loaded {}] [lsort [info commands pkgb_*]]
|
|
} "{{[file join $testDir pkgb$ext] Pkgb} {{} More} {{} Another} {{} Test} {[file join $testDir pkga$ext] Pkga} {{} Tcltest}} {pkgb_sub pkgb_unsafe}"
|
|
interp delete child
|
|
}
|