tcl/tests/load.test

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