1# Commands covered:  unload
2#
3# This file contains a collection of tests for one or more of the Tcl
4# built-in commands.  Sourcing this file into Tcl runs the tests and
5# generates output for errors.  No output means no errors were found.
6#
7# Copyright © 1995 Sun Microsystems, Inc.
8# Copyright © 1998-1999 Scriptics Corporation.
9# Copyright © 2003-2004 Georgios Petasis
10#
11# See the file "license.terms" for information on usage and redistribution
12# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13
14if {"::tcltest" ni [namespace children]} {
15    package require tcltest 2.5
16    namespace import -force ::tcltest::*
17}
18
19::tcltest::loadTestedCommands
20catch [list package require -exact tcl::test [info patchlevel]]
21
22# Figure out what extension is used for shared libraries on this
23# platform.
24if {![info exists ext]} {
25    set ext [info sharedlibextension]
26}
27
28# Tests require the existence of one of the DLLs in the dltest directory.
29set testDir [file join [file dirname [info nameofexecutable]] dltest]
30set x [file join $testDir pkgua$ext]
31set dll "[file tail $x]Required"
32testConstraint $dll [file readable $x]
33
34# Tests also require that this DLL has not already been loaded.
35set loaded "[file tail $x]Loaded"
36set alreadyLoaded [info loaded]
37testConstraint $loaded [expr {![string match *pkgua* $alreadyLoaded]}]
38
39set alreadyTotalLoaded [info loaded]
40
41# Certain tests need the 'testsimplefilsystem' in tcltest
42testConstraint testsimplefilesystem \
43	[llength [info commands testsimplefilesystem]]
44
45proc loadIfNotPresent {pkg args} {
46    global testDir ext
47    set loaded [lmap x [info loaded {*}$args] {lindex $x 1}]
48    if {[string totitle $pkg] ni $loaded} {
49	load [file join $testDir $pkg$ext]
50    }
51}
52
53# Basic tests: parameter testing...
54test unload-1.1 {basic errors} -returnCodes error -body {
55    unload
56} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"}
57test unload-1.2 {basic errors} -returnCodes error -body {
58    unload a b c d
59} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"}
60test unload-1.3 {basic errors} -returnCodes error -body {
61    unload a b foobar
62} -result {could not find interpreter "foobar"}
63test unload-1.4 {basic errors} -returnCodes error -body {
64    unload {}
65} -result {must specify either file name or prefix}
66test unload-1.5 {basic errors} -returnCodes error -body {
67    unload {} {}
68} -result {must specify either file name or prefix}
69test unload-1.6 {basic errors} -returnCodes error -body {
70    unload {} Unknown
71} -result {library with prefix "Unknown" is loaded statically and cannot be unloaded}
72test unload-1.7 {-nocomplain switch} {
73    unload -nocomplain {} Unknown
74} {}
75
76set pkgua_loaded {}
77set pkgua_detached {}
78set pkgua_unloaded {}
79# Tests for loading/unloading in trusted (non-safe) interpreters...
80test unload-2.1 {basic loading of non-unloadable package, with guess for prefix} [list $dll $loaded] {
81    loadIfNotPresent pkga
82    list [pkga_eq abc def] [lsort [info commands pkga_*]]
83} {0 {pkga_eq pkga_quote}}
84test unload-2.2 {basic loading of unloadable package, with guess for prefix} [list $dll $loaded] {
85    list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
86	    [load [file join $testDir pkgua$ext]] \
87	    [pkgua_eq abc def] [lsort [info commands pkgua_*]] \
88	    $pkgua_loaded $pkgua_detached $pkgua_unloaded
89} {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}}
90test unload-2.3 {basic unloading of non-unloadable package, with guess for prefix} -setup {
91    loadIfNotPresent pkga
92} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
93    unload [file join $testDir pkga$ext]
94} -result {file "*" cannot be unloaded under a trusted interpreter}
95test unload-2.4 {basic unloading of unloadable package, with guess for prefix} -setup {
96    loadIfNotPresent pkgua
97} -constraints [list $dll $loaded] -body {
98    list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
99	    [unload [file join $testDir pkgua$ext]] \
100	    [info commands pkgua_*] \
101	    $pkgua_loaded $pkgua_detached $pkgua_unloaded
102} -result {. {} {} {} {} . . .}
103test unload-2.5 {reloading of unloaded package, with guess for prefix} -setup {
104    if {$pkgua_loaded eq ""} {
105	loadIfNotPresent pkgua
106	unload [file join $testDir pkgua$ext]
107    }
108} -constraints [list $dll $loaded] -body {
109    list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
110	    [load [file join $testDir pkgua$ext]] \
111	    [pkgua_eq abc def] [lsort [info commands pkgua_*]] \
112	    $pkgua_loaded $pkgua_detached $pkgua_unloaded
113} -result {. . . {} 0 {pkgua_eq pkgua_quote} .. . .}
114test unload-2.6 {basic unloading of re-loaded package, with guess for prefix} -setup {
115    # Establish expected state
116    if {$pkgua_loaded eq ""} {
117	loadIfNotPresent pkgua
118	unload [file join $testDir pkgua$ext]
119	load [file join $testDir pkgua$ext]
120    }
121} -constraints [list $dll $loaded] -body {
122    list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
123	    [unload [file join $testDir pkgua$ext]] \
124	    [info commands pkgua_*] \
125	    $pkgua_loaded $pkgua_detached $pkgua_unloaded
126} -result {.. . . {} {} .. .. ..}
127
128# Tests for loading/unloading in safe interpreters...
129interp create -safe child
130child eval {
131    set pkgua_loaded {}
132    set pkgua_detached {}
133    set pkgua_unloaded {}
134}
135test unload-3.1 {basic loading of non-unloadable package in a safe interpreter} \
136	[list $dll $loaded] {
137    catch {rename pkgb_sub {}}
138    load [file join $testDir pkgb$ext] Pkgb child
139    list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
140         [catch {pkgb_sub 12 10} msg2] $msg2
141} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
142test unload-3.2 {basic loading of unloadable package in a safe interpreter} \
143	[list $dll $loaded] {
144    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
145	    [load [file join $testDir pkgua$ext] pkgua child] \
146	    [child eval pkgua_eq abc def] \
147	    [lsort [child eval info commands pkgua_*]] \
148	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
149} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
150test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} -setup {
151    loadIfNotPresent pkga
152} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
153    unload [file join $testDir pkga$ext] {} child
154} -result {file "*" has never been loaded in this interpreter}
155test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for prefix} -setup {
156    if {[lsearch -index 1 [info loaded child] Pkgb] < 0} {
157	load [file join $testDir pkgb$ext] Pkgb child
158    }
159} -constraints [list $dll $loaded] -returnCodes error -match glob -body {
160    unload [file join $testDir pkgb$ext] {} child
161} -result {file "*" cannot be unloaded under a safe interpreter}
162test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for prefix} -setup {
163    if {[lsearch -index 1 [info loaded child] Pkgua] < 0} {
164	load [file join $testDir pkgua$ext] Pkgua child
165    }
166} -constraints [list $dll $loaded] -body {
167    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
168	    [unload [file join $testDir pkgua$ext] {} child] \
169	    [child eval info commands pkgua_*] \
170	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
171} -result {{. {} {}} {} {} {. . .}}
172test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for prefix} -setup {
173    if {[child eval set pkgua_loaded] eq ""} {
174	load [file join $testDir pkgua$ext] {} child
175	unload [file join $testDir pkgua$ext] {} child
176    }
177} -constraints [list $dll $loaded] -body {
178    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
179	    [load [file join $testDir pkgua$ext] {} child] \
180	    [child eval pkgua_eq abc def] \
181	    [lsort [child eval info commands pkgua_*]] \
182	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
183} -result {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}}
184test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with prefix conversion} -setup {
185    if {[child eval set pkgua_loaded] eq ""} {
186	load [file join $testDir pkgua$ext] {} child
187	unload [file join $testDir pkgua$ext] {} child
188	load [file join $testDir pkgua$ext] {} child
189    }
190} -constraints [list $dll $loaded] -body {
191    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
192	    [unload [file join $testDir pkgua$ext] pKgUa child] \
193	    [child eval info commands pkgua_*] \
194	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
195} -result {{.. . .} {} {} {.. .. ..}}
196
197# Tests for loading/unloading of a package among multiple interpreters...
198interp create child-trusted
199child-trusted eval {
200    set pkgua_loaded {}
201    set pkgua_detached {}
202    set pkgua_unloaded {}
203}
204array set load {M 0 C 0 T 0}
205## Load package in main trusted interpreter...
206test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for prefix} -setup {
207    set pkgua_loaded ""
208    set pkgua_detached ""
209    set pkgua_unloaded ""
210    incr load(M)
211} -constraints [list $dll $loaded] -body {
212    list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \
213	    [load [file join $testDir pkgua$ext]] \
214	    [pkgua_eq abc def] [lsort [info commands pkgua_*]] \
215	    [list $pkgua_loaded $pkgua_detached $pkgua_unloaded]
216} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
217## Load package in child-safe interpreter...
218test unload-4.2 {basic loading of unloadable package in a safe interpreter} -setup {
219    child eval {
220	set pkgua_loaded ""
221	set pkgua_detached ""
222	set pkgua_unloaded ""
223    }
224    incr load(C)
225} -constraints [list $dll $loaded] -body {
226    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
227	    [load [file join $testDir pkgua$ext] pkgua child] \
228	    [child eval pkgua_eq abc def] \
229	    [lsort [child eval info commands pkgua_*]] \
230	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
231} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
232## Load package in child-trusted interpreter...
233test unload-4.3 {basic loading of unloadable package in a second trusted interpreter} -setup {
234    incr load(T)
235} -constraints [list $dll $loaded] -body {
236    list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
237	    [load [file join $testDir pkgua$ext] pkgua child-trusted] \
238	    [child-trusted eval pkgua_eq abc def] \
239	    [lsort [child-trusted eval info commands pkgua_*]] \
240	    [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
241} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
242## Unload the package from the main trusted interpreter...
243test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for prefix} -setup {
244    if {!$load(M)} {
245	load [file join $testDir pkgua$ext]
246    }
247    if {!$load(C)} {
248	load [file join $testDir pkgua$ext] {} child
249	incr load(C)
250    }
251    if {!$load(T)} {
252	load [file join $testDir pkgua$ext] {} child-trusted
253	incr load(T)
254    }
255} -constraints [list $dll $loaded] -body {
256    list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \
257	    [unload [file join $testDir pkgua$ext]] \
258	    [info commands pkgua_*] \
259	    [list $pkgua_loaded $pkgua_detached $pkgua_unloaded]
260} -result {{. {} {}} {} {} {. . {}}}
261## Unload the package from the child safe interpreter...
262test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup {
263    if {!$load(C)} {
264	load [file join $testDir pkgua$ext] {} child
265    }
266    if {!$load(T)} {
267	load [file join $testDir pkgua$ext] {} child-trusted
268	incr load(T)
269    }
270} -constraints [list $dll $loaded] -body {
271    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
272	    [unload [file join $testDir pkgua$ext] {} child] \
273	    [child eval info commands pkgua_*] \
274	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
275} -result {{. {} {}} {} {} {. . {}}}
276## Unload the package from the child trusted interpreter...
277test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup {
278    if {!$load(T)} {
279	load [file join $testDir pkgua$ext] {} child-trusted
280    }
281} -constraints [list $dll $loaded] -body {
282    list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
283	    [unload [file join $testDir pkgua$ext] {} child-trusted] \
284	    [child-trusted eval info commands pkgua_*] \
285	    [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
286} -result {{. {} {}} {} {} {. . .}}
287
288test unload-5.1 {unload a module loaded from vfs} \
289     -constraints [list $dll $loaded testsimplefilesystem] \
290     -setup {
291	 set dir [pwd]
292	 cd $testDir
293	 testsimplefilesystem 1
294	 load simplefs:/pkgua$ext pkgua
295     } \
296    -body {
297	list [catch {unload simplefs:/pkgua$ext} msg] $msg
298    } \
299    -result {0 {}}
300
301# cleanup
302interp delete child
303interp delete child-trusted
304unset ext
305::tcltest::cleanupTests
306return
307
308# Local Variables:
309# mode: tcl
310# End:
311