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 © 1995 Sun Microsystems, Inc. 8# Copyright © 1998-1999 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 13if {"::tcltest" ni [namespace children]} { 14 package require tcltest 2.5 15 namespace import -force ::tcltest::* 16} 17 18::tcltest::loadTestedCommands 19catch [list package require -exact tcl::test [info patchlevel]] 20 21# Figure out what extension is used for shared libraries on this 22# platform. 23if {![info exists ext]} { 24 set ext [info sharedlibextension] 25} 26# Tests require the existence of one of the DLLs in the dltest directory. 27set testDir [file join [file dirname [info nameofexecutable]] dltest] 28set x [file join $testDir pkga$ext] 29set dll "[file tail $x]Required" 30testConstraint $dll [file readable $x] 31 32# Tests also require that this DLL has not already been loaded. 33set loaded "[file tail $x]Loaded" 34set alreadyLoaded [info loaded] 35testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}] 36 37set alreadyTotalLoaded [info loaded] 38 39# Certain tests require the 'teststaticlibrary' command from tcltest 40 41testConstraint teststaticlibrary [llength [info commands teststaticlibrary]] 42 43# Test load-10.1 requires the 'testsimplefilesystem' command from tcltest 44 45testConstraint testsimplefilesystem \ 46 [llength [info commands testsimplefilesystem]] 47 48test load-1.1 {basic errors} -returnCodes error -body { 49 load 50} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"} 51test load-1.2 {basic errors} -returnCodes error -body { 52 load a b c d 53} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"} 54test load-1.3 {basic errors} -returnCodes error -body { 55 load a b foobar 56} -result {could not find interpreter "foobar"} 57test load-1.4 {basic errors} -returnCodes error -body { 58 load -global {} 59} -result {must specify either file name or prefix} 60test load-1.5 {basic errors} -returnCodes error -body { 61 load -lazy {} {} 62} -result {must specify either file name or prefix} 63test load-1.6 {basic errors} -returnCodes error -body { 64 load {} Unknown 65} -result {no library with prefix "Unknown" is loaded statically} 66test load-1.7 {basic errors} -returnCodes error -body { 67 load -abc foo 68} -result {bad option "-abc": must be -global, -lazy, or --} 69test load-1.8 {basic errors} -returnCodes error -body { 70 load -global 71} -result {couldn't figure out prefix for -global} 72 73test load-2.1 {basic loading, with guess for package name} \ 74 [list $dll $loaded] { 75 load -global [file join $testDir pkga$ext] 76 list [pkga_eq abc def] [lsort [info commands pkga_*]] 77} {0 {pkga_eq pkga_quote}} 78interp create -safe child 79test load-2.2 {loading into a safe interpreter, with package name conversion} \ 80 [list $dll $loaded] { 81 load -lazy [file join $testDir pkgb$ext] Pkgb child 82 list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ 83 [catch {pkgb_sub 12 10} msg2] $msg2 84} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} 85test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \ 86-body { 87 list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode 88} -match glob \ 89 -result [list 1 {cannot find symbol "Foo_Init"*} \ 90 {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] 91test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { 92 list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg 93} {1 {can't use library in a safe interpreter: no Pkga_SafeInit procedure}} 94 95test load-3.1 {error in _Init procedure, same interpreter} \ 96 [list $dll $loaded] { 97 list [catch {load [file join $testDir pkge$ext] pkge} msg] \ 98 $msg $::errorInfo $::errorCode 99} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory 100 while executing 101"open non_existent" 102 invoked from within 103"if 44 {open non_existent}" 104 invoked from within 105"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} 106test load-3.2 {error in _Init procedure, child interpreter} \ 107 [list $dll $loaded] { 108 catch {interp delete x} 109 interp create x 110 set ::errorCode foo 111 set ::errorInfo bar 112 set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ 113 $msg $::errorInfo $::errorCode] 114 interp delete x 115 set result 116} {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory 117 while executing 118"open non_existent" 119 invoked from within 120"if 44 {open non_existent}" 121 invoked from within 122"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} 123 124test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { 125 list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg 126} {0 {}} 127test load-4.2 {reloading package into same interpreter} -setup { 128 catch {load [file join $testDir pkga$ext] Pkga} 129} -constraints [list $dll $loaded] -returnCodes error -body { 130 load [file join $testDir pkga$ext] Pkgb 131} -result "file \"[file join $testDir pkga$ext]\" is already loaded for prefix \"Pkga\"" 132 133test load-5.1 {file name not specified and no static package: pick default} -setup { 134 catch {interp delete x} 135 interp create x 136} -constraints [list $dll $loaded] -body { 137 load -global [file join $testDir pkga$ext] Pkga 138 load {} Pkga x 139 info loaded x 140} -cleanup { 141 interp delete x 142} -result [list [list [file join $testDir pkga$ext] Pkga]] 143 144# On some platforms, like SunOS 4.1.3, these tests can't be run because 145# they cause the process to exit. 146# 147# As of 2005, such ancient broken systems no longer matter. 148 149test load-6.1 {errors loading file} [list $dll $loaded] { 150 catch {load foo foo} 151} {1} 152 153test load-7.1 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { 154 set x "not loaded" 155 teststaticlibrary Test 1 0 156 load {} test 157 load {} test child 158 list [set x] [child eval set x] 159} {loaded loaded} 160test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { 161 set x "not loaded" 162 teststaticlibrary Another 0 0 163 load {} Another 164 child eval {set x "not loaded"} 165 list [catch {load {} Another child} msg] $msg \ 166 [child eval set x] [set x] 167} {1 {can't use library in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} 168test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { 169 set x "not loaded" 170 teststaticlibrary More 0 1 171 load {} more 172 set x 173} {not loaded} 174catch {load [file join $testDir pkga$ext] Pkga} 175catch {load [file join $testDir pkgb$ext] Pkgb} 176catch {load [file join $testDir pkge$ext] Pkge} 177set currentRealLibraries [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] 178test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { 179 teststaticlibrary Test 1 0 180 teststaticlibrary Another 0 0 181 teststaticlibrary More 0 1 182} -constraints [list teststaticlibrary $dll $loaded] -body { 183 teststaticlibrary Double 0 1 184 teststaticlibrary Double 0 1 185 info loaded 186} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded] 187 188testConstraint teststaticlibrary_8.x 0 189if {[testConstraint teststaticlibrary]} { 190 catch { 191 teststaticlibrary Test 1 1 192 teststaticlibrary Another 0 1 193 teststaticlibrary More 0 1 194 teststaticlibrary Double 0 1 195 testConstraint teststaticlibrary_8.x 1 196 } 197} 198 199test load-8.1 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { 200 lsort -index 1 [info loaded] 201} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded]] 202test load-8.2 {TclGetLoadedLibraries procedure} -constraints {teststaticlibrary_8.x} -body { 203 info loaded gorp 204} -returnCodes error -result {could not find interpreter "gorp"} 205test load-8.3a {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { 206 lsort -index 1 [info loaded {}] 207} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] 208test load-8.3b {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { 209 lsort -index 1 [info loaded child] 210} [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] 211test load-8.4 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { 212 load [file join $testDir pkgb$ext] Pkgb 213 list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] 214} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] 215interp delete child 216 217test load-9.1 {Tcl_StaticLibrary, load already-loaded package into another interp} -setup { 218 interp create child1 219 interp create child2 220 load {} Tcltest child1 221 load {} Tcltest child2 222} -constraints {teststaticlibrary} -body { 223 child1 eval { teststaticlibrary Loadninepointone 0 1 } 224 child2 eval { teststaticlibrary Loadninepointone 0 1 } 225 list [child1 eval { info loaded {} }] \ 226 [child2 eval { info loaded {} }] 227} -match glob -cleanup { 228 interp delete child1 229 interp delete child2 230} -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} 231 232test load-10.1 {load from vfs} -setup { 233 set dir [pwd] 234 cd $testDir 235 testsimplefilesystem 1 236} -constraints [list $dll $loaded testsimplefilesystem] -body { 237 list [catch {load simplefs:/pkgd$ext Pkgd} msg] $msg 238} -result {0 {}} -cleanup { 239 testsimplefilesystem 0 240 cd $dir 241 unset dir 242} 243 244test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ 245 [list $dll $loaded] { 246 load [file join $testDir pkgooa$ext] 247 list [pkgooa_stubsok] [lsort [info commands pkgooa_*]] 248} {1 pkgooa_stubsok} 249 250# cleanup 251unset ext 252::tcltest::cleanupTests 253return 254 255# Local Variables: 256# mode: tcl 257# End: 258