|
sl@0
|
1 |
# Commands covered: load
|
|
sl@0
|
2 |
#
|
|
sl@0
|
3 |
# This file contains a collection of tests for one or more of the Tcl
|
|
sl@0
|
4 |
# built-in commands. Sourcing this file into Tcl runs the tests and
|
|
sl@0
|
5 |
# generates output for errors. No output means no errors were found.
|
|
sl@0
|
6 |
#
|
|
sl@0
|
7 |
# Copyright (c) 1995 Sun Microsystems, Inc.
|
|
sl@0
|
8 |
# Copyright (c) 1998-1999 by Scriptics Corporation.
|
|
sl@0
|
9 |
#
|
|
sl@0
|
10 |
# See the file "license.terms" for information on usage and redistribution
|
|
sl@0
|
11 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
sl@0
|
12 |
#
|
|
sl@0
|
13 |
# RCS: @(#) $Id: load.test,v 1.11.2.1 2004/09/14 17:02:56 das Exp $
|
|
sl@0
|
14 |
|
|
sl@0
|
15 |
if {[lsearch [namespace children] ::tcltest] == -1} {
|
|
sl@0
|
16 |
package require tcltest 2
|
|
sl@0
|
17 |
namespace import -force ::tcltest::*
|
|
sl@0
|
18 |
}
|
|
sl@0
|
19 |
|
|
sl@0
|
20 |
# Figure out what extension is used for shared libraries on this
|
|
sl@0
|
21 |
# platform.
|
|
sl@0
|
22 |
|
|
sl@0
|
23 |
if {$tcl_platform(platform) == "macintosh"} {
|
|
sl@0
|
24 |
puts "can't run dynamic library tests on macintosh machines"
|
|
sl@0
|
25 |
::tcltest::cleanupTests
|
|
sl@0
|
26 |
return
|
|
sl@0
|
27 |
}
|
|
sl@0
|
28 |
|
|
sl@0
|
29 |
# Tests require the existence of one of the DLLs in the dltest directory.
|
|
sl@0
|
30 |
set ext [info sharedlibextension]
|
|
sl@0
|
31 |
set testDir [file join [file dirname [info nameofexecutable]] dltest]
|
|
sl@0
|
32 |
set x [file join $testDir pkga$ext]
|
|
sl@0
|
33 |
set dll "[file tail $x]Required"
|
|
sl@0
|
34 |
::tcltest::testConstraint $dll [file readable $x]
|
|
sl@0
|
35 |
|
|
sl@0
|
36 |
# Tests also require that this DLL has not already been loaded.
|
|
sl@0
|
37 |
set loaded "[file tail $x]Loaded"
|
|
sl@0
|
38 |
set alreadyLoaded [info loaded]
|
|
sl@0
|
39 |
::tcltest::testConstraint $loaded \
|
|
sl@0
|
40 |
[expr {![string match *pkga* $alreadyLoaded]}]
|
|
sl@0
|
41 |
|
|
sl@0
|
42 |
set alreadyTotalLoaded [info loaded]
|
|
sl@0
|
43 |
|
|
sl@0
|
44 |
# Certain tests require the 'teststaticpkg' command from tcltest
|
|
sl@0
|
45 |
|
|
sl@0
|
46 |
::tcltest::testConstraint teststaticpkg \
|
|
sl@0
|
47 |
[string compare {} [info commands teststaticpkg]]
|
|
sl@0
|
48 |
|
|
sl@0
|
49 |
|
|
sl@0
|
50 |
test load-1.1 {basic errors} {} {
|
|
sl@0
|
51 |
list [catch {load} msg] $msg
|
|
sl@0
|
52 |
} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
|
|
sl@0
|
53 |
test load-1.2 {basic errors} {} {
|
|
sl@0
|
54 |
list [catch {load a b c d} msg] $msg
|
|
sl@0
|
55 |
} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"
|
|
sl@0
|
56 |
test load-1.3 {basic errors} {} {
|
|
sl@0
|
57 |
list [catch {load a b foobar} msg] $msg
|
|
sl@0
|
58 |
} {1 {could not find interpreter "foobar"}}
|
|
sl@0
|
59 |
test load-1.4 {basic errors} {} {
|
|
sl@0
|
60 |
list [catch {load {}} msg] $msg
|
|
sl@0
|
61 |
} {1 {must specify either file name or package name}}
|
|
sl@0
|
62 |
test load-1.5 {basic errors} {} {
|
|
sl@0
|
63 |
list [catch {load {} {}} msg] $msg
|
|
sl@0
|
64 |
} {1 {must specify either file name or package name}}
|
|
sl@0
|
65 |
test load-1.6 {basic errors} {} {
|
|
sl@0
|
66 |
list [catch {load {} Unknown} msg] $msg
|
|
sl@0
|
67 |
} {1 {package "Unknown" isn't loaded statically}}
|
|
sl@0
|
68 |
|
|
sl@0
|
69 |
test load-2.1 {basic loading, with guess for package name} \
|
|
sl@0
|
70 |
[list $dll $loaded] {
|
|
sl@0
|
71 |
load [file join $testDir pkga$ext]
|
|
sl@0
|
72 |
list [pkga_eq abc def] [info commands pkga_*]
|
|
sl@0
|
73 |
} {0 {pkga_eq pkga_quote}}
|
|
sl@0
|
74 |
interp create -safe child
|
|
sl@0
|
75 |
test load-2.2 {loading into a safe interpreter, with package name conversion} \
|
|
sl@0
|
76 |
[list $dll $loaded] {
|
|
sl@0
|
77 |
load [file join $testDir pkgb$ext] pKgB child
|
|
sl@0
|
78 |
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
|
|
sl@0
|
79 |
[catch {pkgb_sub 12 10} msg2] $msg2
|
|
sl@0
|
80 |
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
|
|
sl@0
|
81 |
test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
|
|
sl@0
|
82 |
-body {
|
|
sl@0
|
83 |
list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg
|
|
sl@0
|
84 |
} -match glob -result {1 {*couldn't find procedure Foo_Init}}
|
|
sl@0
|
85 |
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
|
|
sl@0
|
86 |
list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
|
|
sl@0
|
87 |
} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}
|
|
sl@0
|
88 |
|
|
sl@0
|
89 |
test load-3.1 {error in _Init procedure, same interpreter} \
|
|
sl@0
|
90 |
[list $dll $loaded] {
|
|
sl@0
|
91 |
list [catch {load [file join $testDir pkge$ext] pkge} msg] \
|
|
sl@0
|
92 |
$msg $errorInfo $errorCode
|
|
sl@0
|
93 |
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
|
|
sl@0
|
94 |
while executing
|
|
sl@0
|
95 |
"open non_existent"
|
|
sl@0
|
96 |
invoked from within
|
|
sl@0
|
97 |
"if 44 {open non_existent}"
|
|
sl@0
|
98 |
invoked from within
|
|
sl@0
|
99 |
"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}
|
|
sl@0
|
100 |
test load-3.2 {error in _Init procedure, slave interpreter} \
|
|
sl@0
|
101 |
[list $dll $loaded] {
|
|
sl@0
|
102 |
catch {interp delete x}
|
|
sl@0
|
103 |
interp create x
|
|
sl@0
|
104 |
set errorCode foo
|
|
sl@0
|
105 |
set errorInfo bar
|
|
sl@0
|
106 |
set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \
|
|
sl@0
|
107 |
$msg $errorInfo $errorCode]
|
|
sl@0
|
108 |
interp delete x
|
|
sl@0
|
109 |
set result
|
|
sl@0
|
110 |
} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
|
|
sl@0
|
111 |
while executing
|
|
sl@0
|
112 |
"open non_existent"
|
|
sl@0
|
113 |
invoked from within
|
|
sl@0
|
114 |
"if 44 {open non_existent}"
|
|
sl@0
|
115 |
invoked from within
|
|
sl@0
|
116 |
"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}}
|
|
sl@0
|
117 |
|
|
sl@0
|
118 |
test load-4.1 {reloading package into same interpreter} [list $dll $loaded] {
|
|
sl@0
|
119 |
list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg
|
|
sl@0
|
120 |
} {0 {}}
|
|
sl@0
|
121 |
test load-4.2 {reloading package into same interpreter} [list $dll $loaded] {
|
|
sl@0
|
122 |
list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg
|
|
sl@0
|
123 |
} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]
|
|
sl@0
|
124 |
|
|
sl@0
|
125 |
test load-5.1 {file name not specified and no static package: pick default} \
|
|
sl@0
|
126 |
[list $dll $loaded] {
|
|
sl@0
|
127 |
catch {interp delete x}
|
|
sl@0
|
128 |
interp create x
|
|
sl@0
|
129 |
load [file join $testDir pkga$ext] pkga
|
|
sl@0
|
130 |
load {} pkga x
|
|
sl@0
|
131 |
set result [info loaded x]
|
|
sl@0
|
132 |
interp delete x
|
|
sl@0
|
133 |
set result
|
|
sl@0
|
134 |
} [list [list [file join $testDir pkga$ext] Pkga]]
|
|
sl@0
|
135 |
|
|
sl@0
|
136 |
# On some platforms, like SunOS 4.1.3, these tests can't be run because
|
|
sl@0
|
137 |
# they cause the process to exit.
|
|
sl@0
|
138 |
|
|
sl@0
|
139 |
test load-6.1 {errors loading file} [list $dll $loaded nonPortable] {
|
|
sl@0
|
140 |
catch {load foo foo}
|
|
sl@0
|
141 |
} {1}
|
|
sl@0
|
142 |
|
|
sl@0
|
143 |
test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] {
|
|
sl@0
|
144 |
set x "not loaded"
|
|
sl@0
|
145 |
teststaticpkg Test 1 0
|
|
sl@0
|
146 |
load {} Test
|
|
sl@0
|
147 |
load {} Test child
|
|
sl@0
|
148 |
list [set x] [child eval set x]
|
|
sl@0
|
149 |
} {loaded loaded}
|
|
sl@0
|
150 |
test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] {
|
|
sl@0
|
151 |
set x "not loaded"
|
|
sl@0
|
152 |
teststaticpkg Another 0 0
|
|
sl@0
|
153 |
load {} Another
|
|
sl@0
|
154 |
child eval {set x "not loaded"}
|
|
sl@0
|
155 |
list [catch {load {} Another child} msg] $msg \
|
|
sl@0
|
156 |
[child eval set x] [set x]
|
|
sl@0
|
157 |
} {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}
|
|
sl@0
|
158 |
test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] {
|
|
sl@0
|
159 |
set x "not loaded"
|
|
sl@0
|
160 |
teststaticpkg More 0 1
|
|
sl@0
|
161 |
load {} More
|
|
sl@0
|
162 |
set x
|
|
sl@0
|
163 |
} {not loaded}
|
|
sl@0
|
164 |
test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \
|
|
sl@0
|
165 |
[list teststaticpkg $dll $loaded] {
|
|
sl@0
|
166 |
teststaticpkg Double 0 1
|
|
sl@0
|
167 |
teststaticpkg Double 0 1
|
|
sl@0
|
168 |
info loaded
|
|
sl@0
|
169 |
} [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]
|
|
sl@0
|
170 |
|
|
sl@0
|
171 |
test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
|
|
sl@0
|
172 |
info loaded
|
|
sl@0
|
173 |
} [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]
|
|
sl@0
|
174 |
test load-8.2 {TclGetLoadedPackages procedure} [list teststaticpkg] {
|
|
sl@0
|
175 |
list [catch {info loaded gorp} msg] $msg
|
|
sl@0
|
176 |
} {1 {could not find interpreter "gorp"}}
|
|
sl@0
|
177 |
test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {
|
|
sl@0
|
178 |
list [info loaded {}] [info loaded child]
|
|
sl@0
|
179 |
} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]
|
|
sl@0
|
180 |
test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {
|
|
sl@0
|
181 |
load [file join $testDir pkgb$ext] pkgb
|
|
sl@0
|
182 |
list [info loaded {}] [lsort [info commands pkgb_*]]
|
|
sl@0
|
183 |
} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_sub pkgb_unsafe}]
|
|
sl@0
|
184 |
interp delete child
|
|
sl@0
|
185 |
|
|
sl@0
|
186 |
test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \
|
|
sl@0
|
187 |
-constraints {teststaticpkg} \
|
|
sl@0
|
188 |
-setup {
|
|
sl@0
|
189 |
interp create child1
|
|
sl@0
|
190 |
interp create child2
|
|
sl@0
|
191 |
load {} Tcltest child1
|
|
sl@0
|
192 |
load {} Tcltest child2
|
|
sl@0
|
193 |
} \
|
|
sl@0
|
194 |
-body {
|
|
sl@0
|
195 |
child1 eval { teststaticpkg Loadninepointone 0 1 }
|
|
sl@0
|
196 |
child2 eval { teststaticpkg Loadninepointone 0 1 }
|
|
sl@0
|
197 |
list \
|
|
sl@0
|
198 |
[child1 eval { info loaded {} }] \
|
|
sl@0
|
199 |
[child2 eval { info loaded {} }]
|
|
sl@0
|
200 |
} \
|
|
sl@0
|
201 |
-result {{{{} Loadninepointone} {{} Tcltest}} {{{} Loadninepointone} {{} Tcltest}}} \
|
|
sl@0
|
202 |
-cleanup { interp delete child1 ; interp delete child2 }
|
|
sl@0
|
203 |
|
|
sl@0
|
204 |
|
|
sl@0
|
205 |
# cleanup
|
|
sl@0
|
206 |
::tcltest::cleanupTests
|
|
sl@0
|
207 |
return
|