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: http://www.privyetmir.co.uk/gitweb?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