TIP#100 implementation largely based on work by Georgios Petasis.

1 files changed, 223 insertions, 0 deletions

diff --git a/tests/unload.test b/tests/unload.test
new file mode 100644
index 0000000..00d6970
--- /dev/null
+++ b/tests/unload.test
@@ -0,0 +1,223 @@
+# Commands covered:  unload
+#
+# 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.
+# Copyright (c) 2003-2004 by Georgios Petasis
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: unload.test,v 1.1 2004/02/24 22:58:48 dkf 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 pkgua$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 *pkgua* $alreadyLoaded]}]
+
+set alreadyTotalLoaded [info loaded]
+
+# Certain tests require the 'teststaticpkg' command from tcltest
+::tcltest::testConstraint teststaticpkg \
+	[string compare {} [info commands teststaticpkg]]
+
+# Basic tests: parameter testing...
+test unload-1.1 {basic errors} {} {
+    list [catch {unload} msg] $msg
+} "1 {wrong \# args: should be \"unload ?switches? fileName ?packageName? ?interp?\"}"
+test unload-1.2 {basic errors} {} {
+    list [catch {unload a b c d} msg] $msg
+} "1 {wrong \# args: should be \"unload ?switches? fileName ?packageName? ?interp?\"}"
+test unload-1.3 {basic errors} {} {
+    list [catch {unload a b foobar} msg] $msg
+} {1 {could not find interpreter "foobar"}}
+test unload-1.4 {basic errors} {} {
+    list [catch {unload {}} msg] $msg
+} {1 {must specify either file name or package name}}
+test unload-1.5 {basic errors} {} {
+    list [catch {unload {} {}} msg] $msg
+} {1 {must specify either file name or package name}}
+test unload-1.6 {basic errors} {} {
+    list [catch {unload {} Unknown} msg] $msg
+} {1 {package "Unknown" is loaded statically and cannot be unloaded}}
+test unload-1.7 {-nocomplain switch} {} {
+    list [unload -nocomplain {} Unknown]
+} {{}}
+
+set pkgua_loaded {}
+set pkgua_detached {}
+set pkgua_unloaded {}
+# Tests for loading/unloading in trusted (non-safe) interpreters...
+test unload-2.1 {basic loading of non-unloadable package, with guess for package name} [list $dll $loaded] {
+    load [file join $testDir pkga$ext]
+    list [pkga_eq abc def] [lsort [info commands pkga_*]]
+} {0 {pkga_eq pkga_quote}}
+test unload-2.2 {basic loading of unloadable package, with guess for package name} [list $dll $loaded] {
+    list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
+	    [load [file join $testDir pkgua$ext]] \
+	    [pkgua_eq abc def] [lsort [info commands pkgua_*]] \
+	    $pkgua_loaded $pkgua_detached $pkgua_unloaded
+} {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}}
+test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} [list $dll $loaded] {
+    list [catch {unload [file join $testDir pkga$ext]} msg] \
+	    [string map [list [file join $testDir pkga$ext] file] $msg]
+} {1 {file "file" cannot be unloaded under a trusted interpreter}}
+test unload-2.4 {basic unloading of unloadable package, with guess for package name} [list $dll $loaded] {
+    list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
+	    [unload [file join $testDir pkgua$ext]] \
+	    [info commands pkgua_*] \
+	    $pkgua_loaded $pkgua_detached $pkgua_unloaded
+} {. {} {} {} {} . . .}
+test unload-2.5 {reloading of unloaded package, with guess for package name} [list $dll $loaded] {
+    list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
+	    [load [file join $testDir pkgua$ext]] \
+	    [pkgua_eq abc def] [lsort [info commands pkgua_*]] \
+	    $pkgua_loaded $pkgua_detached $pkgua_unloaded
+} {. . . {} 0 {pkgua_eq pkgua_quote} .. . .}
+test unload-2.6 {basic unloading of re-loaded package, with guess for package name} [list $dll $loaded] {
+    list $pkgua_loaded $pkgua_detached $pkgua_unloaded \
+	    [unload [file join $testDir pkgua$ext]] \
+	    [info commands pkgua_*] \
+	    $pkgua_loaded $pkgua_detached $pkgua_unloaded
+} {.. . . {} {} .. .. ..}
+
+# Tests for loading/unloading in safe interpreters...
+interp create -safe child
+child eval {
+    set pkgua_loaded {}
+    set pkgua_detached {}
+    set pkgua_unloaded {}
+}
+test unload-3.1 {basic loading of non-unloadable package in 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 unload-3.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \
+	[list $dll $loaded] {
+    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
+	    [load [file join $testDir pkgua$ext] pKgUA child] \
+	    [child eval pkgua_eq abc def] \
+	    [lsort [child eval info commands pkgua_*]] \
+	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
+} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
+test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} \
+	[list $dll $loaded] {
+    list [catch {unload [file join $testDir pkga$ext] {} child} msg] \
+         [string map [list [file join $testDir pkga$ext] file] $msg]
+} {1 {file "file" has never been loaded in this interpreter}}
+test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} \
+	[list $dll $loaded] {
+    list [catch {unload [file join $testDir pkgb$ext] {} child} msg] \
+         [string map [list [file join $testDir pkgb$ext] file] $msg]
+} {1 {file "file" cannot be unloaded under a safe interpreter}}
+test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} \
+	[list $dll $loaded] {
+    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
+	    [unload [file join $testDir pkgua$ext] {} child] \
+	    [child eval info commands pkgua_*] \
+	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
+} {{. {} {}} {} {} {. . .}}
+test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} \
+	[list $dll $loaded] {
+    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
+	    [load [file join $testDir pkgua$ext] {} child] \
+	    [child eval pkgua_eq abc def] \
+	    [lsort [child eval info commands pkgua_*]] \
+	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
+} {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}}
+test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} \
+	[list $dll $loaded] {
+    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
+	    [unload [file join $testDir pkgua$ext] pKgUa child] \
+	    [child eval info commands pkgua_*] \
+	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
+} {{.. . .} {} {} {.. .. ..}}
+
+# Tests for loading/unloading of a package among multiple interpreters...
+interp create child-trusted
+child-trusted eval {
+    set pkgua_loaded {}
+    set pkgua_detached {}
+    set pkgua_unloaded {}
+}
+## Load package in main trusted interpreter...
+test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} \
+	[list $dll $loaded] {
+    list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \
+	    [load [file join $testDir pkgua$ext]] \
+	    [pkgua_eq abc def] [lsort [info commands pkgua_*]] \
+	    [list $pkgua_loaded $pkgua_detached $pkgua_unloaded]
+} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}}
+## Load package in child-safe interpreter...
+test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \
+	[list $dll $loaded] {
+    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
+	    [load [file join $testDir pkgua$ext] pKgUA child] \
+	    [child eval pkgua_eq abc def] \
+	    [lsort [child eval info commands pkgua_*]] \
+	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
+} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}}
+## Load package in child-trusted interpreter...
+test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} \
+	[list $dll $loaded] {
+    list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
+	    [load [file join $testDir pkgua$ext] pkguA child-trusted] \
+	    [child-trusted eval pkgua_eq abc def] \
+	    [lsort [child-trusted eval info commands pkgua_*]] \
+	    [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
+} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}}
+## Unload the package from the main trusted interpreter...
+test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} \
+	[list $dll $loaded] {
+    list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \
+	    [unload [file join $testDir pkgua$ext]] \
+	    [info commands pkgua_*] \
+	    [list $pkgua_loaded $pkgua_detached $pkgua_unloaded]
+} {{... .. ..} {} {} {... ... ..}}
+## Unload the package from the child safe interpreter...
+test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \
+	[list $dll $loaded] {
+    list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
+	    [unload [file join $testDir pkgua$ext] {} child] \
+	    [child eval info commands pkgua_*] \
+	    [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
+} {{... .. ..} {} {} {... ... ..}}
+## Unload the package from the child trusted interpreter...
+test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \
+	[list $dll $loaded] {
+    list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \
+	    [unload [file join $testDir pkgua$ext] {} child-trusted] \
+	    [child-trusted eval info commands pkgua_*] \
+	    [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}]
+} {{. {} {}} {} {} {. . .}}
+
+# cleanup
+::tcltest::cleanupTests
+return