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