From: Vince Darley <vincentdarley@sourceforge.net>
Date: Tue, 20 Jan 2004 15:25:14 +0000 (+0000)
Subject: test suite overhaul
X-Git-Tag: vfs-1-4~106
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=c53de1eca48876459a19933879bc76597cc0d8c1;p=tclvfs

test suite overhaul
---

diff --git a/library/pkgIndex.tcl b/library/pkgIndex.tcl
index 0abc57f..dfc587a 100644
--- a/library/pkgIndex.tcl
+++ b/library/pkgIndex.tcl
@@ -26,10 +26,16 @@ if {$::tcl_platform(platform) eq "unix"} {
 } else {
     set dll vfs13
 }
+if {![info exists dir]} {
+    set dir [file dirname [info script]]
+}
 set dll [file join $dir $dll[info sharedlibextension]]
 
-proc loadvfs {dll} {
+proc loadvfs {dir dll} {
     global auto_path
+    if {[lsearch -exact $auto_path $dir] == -1} {
+	lappend auto_path $dir
+    }
     if {![file exists $dll]} { return }
     set dir [file dirname $dll]
     if {[lsearch -exact $auto_path $dir] == -1} {
@@ -38,7 +44,7 @@ proc loadvfs {dll} {
     load $dll
 }
 
-package ifneeded vfs 1.3.0 [list loadvfs $dll]
+package ifneeded vfs 1.3.0 [list loadvfs $dir $dll]
 package ifneeded starkit 1.3 [list source [file join $dir starkit.tcl]]
 package ifneeded vfslib 1.3.1 [list source [file join $dir vfslib.tcl]]
 
diff --git a/tests/all.tcl b/tests/all.tcl
index ca09d26..1a63d43 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -1 +1,93 @@
-# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests.  Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
# Copyright (c) 1998-2000 by Scriptics Corporation.
# All rights reserved.
# 
# RCS: @(#) $Id$

set tcltestVersion [package require tcltest]
namespace import -force tcltest::*

#tcltest::testsDirectory [file dir [info script]]
#tcltest::runAllTests

set ::tcltest::testSingleFile false
set ::tcltest::testsDirectory [file dir [info script]]

# We need to ensure that the testsDirectory is absolute
::tcltest::normalizePath ::tcltest::testsDirectory

puts stdout "Tests running in interp:  [info nameofexecutable]"
puts stdout "Tests running in working dir:  $::tcltest::testsDirectory"
if {[llength $::tcltest::skip] > 0} {
    puts stdout "Skipping tests that match:  $::tcltest::skip"
}
if {[llength $::tcltest::match] > 0} {
    puts stdout "Only running tests that match:  $::tcltest::match"
}

if {[llength $::tcltest::skipFiles] > 0} {
    puts stdout "Skipping test files that match:  $::tcltest::skipFiles"
}
if {[llength $::tcltest::matchFiles] > 0} {
    puts stdout "Only sourcing test files that match:  $::tcltest::matchFiles"
}

tcltest::testConstraint fsIsWritable [expr {1 - [catch {file mkdir isreadonly ; file delete isreadonly}]}]

set timeCmd {clock format [clock seconds]}
puts stdout "Tests began at [eval $timeCmd]"

# source each of the specified tests
foreach file [lsort [::tcltest::getMatchingFiles]] {
    set tail [file tail $file]
    puts stdout $tail
    if {[catch {source $file} msg]} {
	puts stdout $msg
    }
}

# cleanup
puts stdout "\nTests ended at [eval $timeCmd]"
::tcltest::cleanupTests 1
return

\ No newline at end of file
+# all.tcl --
+#
+# This file contains a top-level script to run all of the Tcl
+# tests.  Execute it by invoking "source all.test" when running tcltest
+# in this directory.
+#
+# Copyright (c) 1998-2000 by Scriptics Corporation.
+# All rights reserved.
+# 
+# RCS: @(#) $Id$
+
+set tcltestVersion [package require tcltest]
+namespace import -force tcltest::*
+
+#tcltest::testsDirectory [file dir [info script]]
+#tcltest::runAllTests
+
+set ::tcltest::testSingleFile false
+set ::tcltest::testsDirectory [file dir [info script]]
+
+proc vfsCreateInterp {name} {
+    # Have to make sure we load the same dll else we'll have multiple
+    # copies!
+    if {[catch {
+	interp create $name 
+	$name eval [list package ifneeded vfs 1.3 [package ifneeded vfs 1.3]]
+	$name eval [list set ::auto_path $::auto_path]
+	$name eval {package require vfs}
+    } err]} {
+	puts "$err ; $::errorInfo"
+    }
+}
+
+# Set up auto_path and package indices for loading.  Must make sure we 
+# can load the same dll into the main interpreter and sub interps.
+proc setupForVfs {lib} {
+    namespace eval vfs {}
+    global auto_path dir vfs::dll
+    set dir [file norm $lib]
+    set auto_path [linsert $auto_path 0 $dir]
+    uplevel \#0 [list source [file join $dir pkgIndex.tcl]]
+    set orig [package ifneeded vfs 1.3]
+    set vfs::dll [lindex $orig 2]
+    if {![file exists $vfs::dll]} {
+	set vfs::dll [file join [pwd] [file tail $vfs::dll]]
+	package ifneeded vfs 1.3 [list [lindex $orig 0] [lindex $orig 1] $vfs::dll]
+    }
+}
+
+# We need to ensure that the testsDirectory is absolute
+::tcltest::normalizePath ::tcltest::testsDirectory
+
+if {[lindex [file system $::tcltest::testsDirectory] 0] == "native"} {
+    setupForVfs [file join [file dir $::tcltest::testsDirectory] library]
+}
+
+package require vfs
+
+puts stdout "Tests running in interp:  [info nameofexecutable]"
+puts stdout "Tests running in working dir:  $::tcltest::testsDirectory"
+if {[llength $::tcltest::skip] > 0} {
+    puts stdout "Skipping tests that match:  $::tcltest::skip"
+}
+if {[llength $::tcltest::match] > 0} {
+    puts stdout "Only running tests that match:  $::tcltest::match"
+}
+
+if {[llength $::tcltest::skipFiles] > 0} {
+    puts stdout "Skipping test files that match:  $::tcltest::skipFiles"
+}
+if {[llength $::tcltest::matchFiles] > 0} {
+    puts stdout "Only sourcing test files that match:  $::tcltest::matchFiles"
+}
+
+tcltest::testConstraint fsIsWritable [expr {1 - [catch {file mkdir isreadonly ; file delete isreadonly}]}]
+
+set timeCmd {clock format [clock seconds]}
+puts stdout "Tests began at [eval $timeCmd]"
+
+# source each of the specified tests
+foreach file [lsort [::tcltest::getMatchingFiles]] {
+    set tail [file tail $file]
+    puts stdout $tail
+    if {[catch {source $file} msg]} {
+	puts stdout $msg
+    }
+}
+
+# cleanup
+puts stdout "\nTests ended at [eval $timeCmd]"
+::tcltest::cleanupTests 1
+return
+
diff --git a/tests/vfs.test b/tests/vfs.test
index 3f720c0..a3a62d4 100644
--- a/tests/vfs.test
+++ b/tests/vfs.test
@@ -57,12 +57,12 @@ test vfs-1.1 {mount unmount} {
 test vfs-2.1 {mount unmount in sub interp} {
     catch {interp delete a}
     catch {unset res}
-    set res {}
     set remove [vfs::filesystem info]
     vfs::filesystem mount foo bar
-    interp create a
+    vfsCreateInterp a
     a eval {package require vfs}
     a eval {vfs::filesystem mount foo2 bar2}
+    set res {}
     eval lappend res [vfs::filesystem info]
     a eval {vfs::filesystem unmount foo2}
     interp delete a
@@ -76,7 +76,7 @@ test vfs-2.2 {mount, delete sub interp} {
     catch {unset res}
     set remove [vfs::filesystem info]
     vfs::filesystem mount foo bar
-    interp create a
+    vfsCreateInterp a
     a eval {package require vfs}
     a eval {vfs::filesystem mount foo2 bar2}
     set res {}
diff --git a/tests/vfsArchive.test b/tests/vfsArchive.test
index b2fa9a7..338d071 100644
--- a/tests/vfsArchive.test
+++ b/tests/vfsArchive.test
@@ -48,24 +48,38 @@ proc makeAndMountMk4Archive {} {
     return [list vfs::mk4::Unmount $mount tests.bin]
 }
 
+# This actually calls the test suite recursively, which probably
+# causes some problems, although it shouldn't really!
+test vfsArchive-1.0 {package require vfs} {
+    if {![catch {package require vfs} res]} {
+	set res "ok"
+    }
+    set res
+} {ok}
+
 # This actually calls the test suite recursively, which probably
 # causes some problems, although it shouldn't really!
 test vfsArchive-1.1 {run tests in zip archive} {nativefs} {
     # If this test fails, you probably don't have 'zip' installed.
     set testdir [pwd]
-    puts stderr $testdir
     package require vfs
     if {[catch {makeAndMountZipArchive} unmount]} {
-	set res "Couldn't make zip archive to test with: $unmount"
+	set res "Couldn't make and mount zip archive to test with: $unmount"
+	puts $::errorInfo
 	puts stderr $::auto_path
     } else {
-	cd tests
-	source all.tcl
-	cd ..
-	cd ..
-	puts [pwd]
-	eval $unmount
-	set res "ok"
+	puts stdout "=== Running tests in zip archive ==="
+	if {![catch {
+	    cd tests
+	    source all.tcl
+	    cd ..
+	    cd ..
+	    puts [pwd]
+	    eval $unmount
+	} res]} {
+	    set res "ok"
+	}
+	puts stdout "=== End of embedded zip tests ==="
     }
     cd $testdir
     set res
@@ -81,9 +95,10 @@ test vfsArchive-1.2 {run tests in mk4 archive} {nativefs} {
     puts stderr $testdir
     package require vfs
     if {[catch {makeAndMountMk4Archive} unmount]} {
-	set res "Couldn't make mk4 archive to test with: $unmount"
+	set res "Couldn't make and mount mk4 archive to test with: $unmount"
 	puts stderr $::auto_path
     } else {
+	puts stdout "=== Running tests in mk4 archive ==="
 	cd tests
 	source all.tcl
 	cd ..
@@ -91,6 +106,7 @@ test vfsArchive-1.2 {run tests in mk4 archive} {nativefs} {
 	puts [pwd]
 	eval $unmount
 	set res "ok"
+	puts stdout "=== End of embedded mk4 tests ==="
     }
     cd $testdir
     set res