# Commands covered:  load

 #

 # This file contains a collection of tests for one or more of the Tcl

 # built-in commands.  Sourcing this file into Tcl runs the tests and

 # generates output for errors.  No output means no errors were found.

 #

 # Copyright (c) 1995 Sun Microsystems, Inc.

 # Copyright (c) 1998-1999 by Scriptics Corporation.

 #

 # See the file "license.terms" for information on usage and redistribution

 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.

 #

 # RCS: @(#) $Id: load.test,v 1.11.2.1 2004/09/14 17:02:56 das Exp $

 if {[lsearch [namespace children] ::tcltest] == -1} {

     package require tcltest 2

     namespace import -force ::tcltest::*

 }

 # Figure out what extension is used for shared libraries on this

 # platform.

 if {$tcl_platform(platform) == "macintosh"} {

     puts "can't run dynamic library tests on macintosh machines"

     ::tcltest::cleanupTests

     return

 }

 # Tests require the existence of one of the DLLs in the dltest directory.

 set ext [info sharedlibextension]

 set testDir [file join [file dirname [info nameofexecutable]] dltest]

 set x [file join $testDir pkga$ext]

 set dll "[file tail $x]Required"

 ::tcltest::testConstraint $dll [file readable $x]

 # Tests also require that this DLL has not already been loaded.

 set loaded "[file tail $x]Loaded"

 set alreadyLoaded [info loaded]

 ::tcltest::testConstraint $loaded \

 	[expr {![string match *pkga* $alreadyLoaded]}]

 set alreadyTotalLoaded [info loaded]

 # Certain tests require the 'teststaticpkg' command from tcltest

 ::tcltest::testConstraint teststaticpkg \

     [string compare {} [info commands teststaticpkg]]

 test load-1.1 {basic errors} {} {

     list [catch {load} msg] $msg

 } "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"

 test load-1.2 {basic errors} {} {

     list [catch {load a b c d} msg] $msg

 } "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}"

 test load-1.3 {basic errors} {} {

     list [catch {load a b foobar} msg] $msg

 } {1 {could not find interpreter "foobar"}}

 test load-1.4 {basic errors} {} {

     list [catch {load {}} msg] $msg

 } {1 {must specify either file name or package name}}

 test load-1.5 {basic errors} {} {

     list [catch {load {} {}} msg] $msg

 } {1 {must specify either file name or package name}}

 test load-1.6 {basic errors} {} {

     list [catch {load {} Unknown} msg] $msg

 } {1 {package "Unknown" isn't loaded statically}}

 test load-2.1 {basic loading, with guess for package name} \

 	[list $dll $loaded] {

     load [file join $testDir pkga$ext]

     list [pkga_eq abc def] [info commands pkga_*]

 } {0 {pkga_eq pkga_quote}}

 interp create -safe child

 test load-2.2 {loading into a safe interpreter, with package name conversion} \

 	[list $dll $loaded] {

     load [file join $testDir pkgb$ext] pKgB child

     list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \

 	    [catch {pkgb_sub 12 10} msg2] $msg2

 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}

 test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \

 -body {

     list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg

 } -match glob -result {1 {*couldn't find procedure Foo_Init}}

 test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {

     list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg

 } {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}

 test load-3.1 {error in _Init procedure, same interpreter} \

 	[list $dll $loaded] {

     list [catch {load [file join $testDir pkge$ext] pkge} msg] \

 	    $msg $errorInfo $errorCode

 } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory

     while executing

 "open non_existent"

     invoked from within

 "if 44 {open non_existent}"

     invoked from within

 "load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}}

 test load-3.2 {error in _Init procedure, slave interpreter} \

 	[list $dll $loaded] {

     catch {interp delete x}

     interp create x

     set errorCode foo

     set errorInfo bar

     set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \

 	    $msg $errorInfo $errorCode]

     interp delete x

     set result

 } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory

     while executing

 "open non_existent"

     invoked from within

 "if 44 {open non_existent}"

     invoked from within

 "load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}}

 test load-4.1 {reloading package into same interpreter} [list $dll $loaded] {

     list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg

 } {0 {}}

 test load-4.2 {reloading package into same interpreter} [list $dll $loaded] {

     list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg

 } [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""]

 test load-5.1 {file name not specified and no static package: pick default} \

 	[list $dll $loaded] {

     catch {interp delete x}

     interp create x

     load [file join $testDir pkga$ext] pkga

     load {} pkga x

     set result [info loaded x]

     interp delete x

     set result

 } [list [list [file join $testDir pkga$ext] Pkga]]

 # On some platforms, like SunOS 4.1.3, these tests can't be run because

 # they cause the process to exit.

 test load-6.1 {errors loading file} [list $dll $loaded nonPortable] {

     catch {load foo foo}

 } {1}

 test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] {

     set x "not loaded"

     teststaticpkg Test 1 0

     load {} Test

     load {} Test child

     list [set x] [child eval set x]

 } {loaded loaded}

 test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] {

     set x "not loaded"

     teststaticpkg Another 0 0

     load {} Another

     child eval {set x "not loaded"}

     list [catch {load {} Another child} msg] $msg \

 	[child eval set x] [set x]

 } {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded}

 test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] {

     set x "not loaded"

     teststaticpkg More 0 1

     load {} More

     set x

 } {not loaded}

 test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \

     [list teststaticpkg $dll $loaded] {

 	teststaticpkg Double 0 1

 	teststaticpkg Double 0 1

 	info loaded

     } [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]

 test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {

     info loaded

 } [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]

 test load-8.2 {TclGetLoadedPackages procedure} [list teststaticpkg] {

     list [catch {info loaded gorp} msg] $msg

 } {1 {could not find interpreter "gorp"}}

 test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] {

     list [info loaded {}] [info loaded child]

 } [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]]

 test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] {

     load [file join $testDir pkgb$ext] pkgb

     list [info loaded {}] [lsort [info commands pkgb_*]]

 } [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}]

 interp delete child

 test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \

     -constraints {teststaticpkg} \

     -setup {

 	interp create child1

 	interp create child2

 	load {} Tcltest child1

 	load {} Tcltest child2

     } \

     -body {

 	child1 eval { teststaticpkg Loadninepointone 0 1 }

 	child2 eval { teststaticpkg Loadninepointone 0 1 }

 	list \

 	    [child1 eval { info loaded {} }] \

 	    [child2 eval { info loaded {} }]

     } \

     -result {{{{} Loadninepointone} {{} Tcltest}} {{{} Loadninepointone} {{} Tcltest}}} \

     -cleanup { interp delete child1 ; interp delete child2 }

 # cleanup

 ::tcltest::cleanupTests

 return