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