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