From: Vince Darley <vincentdarley@sourceforge.net>
Date: Tue, 7 May 2002 08:41:56 +0000 (+0000)
Subject: better tests
X-Git-Tag: vfs-1-2~49
X-Git-Url: http://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=7c1270b4939c7f18f8f69eabc2ff56f59380e59d;p=tclvfs

better tests
---

diff --git a/ChangeLog b/ChangeLog
index b28f225..990b057 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2002-05-03  Vince Darley <vincentdarley@sourceforge.net>
+	* tests/*: more test improvements, and new file vfsArchive.test
+	which will test the running of the tests inside an archive. 
+	This requires recursive invocation of the 'tcltest' package,
+	which may well cause some problems if it isn't designed to
+	handle that (i.e. executing one test actually causes the
+	execution of a lot of other tests).
+	* library/pkgIndex.tcl: update to try to avoid the 'no such
+	command vfs::*::Mount' error messages which you can get, if
+	the relevant .tcl files are not on your auto_path.
+
 2002-05-02  Vince Darley <vincentdarley@sourceforge.net>
 	* tests/vfs.test: tests work independent of directory in which
 	they run.  Tests added to check that at least 'vfs::memchan'
diff --git a/library/pkgIndex.tcl b/library/pkgIndex.tcl
index 0aefcc6..2e4ae13 100644
--- a/library/pkgIndex.tcl
+++ b/library/pkgIndex.tcl
@@ -20,10 +20,6 @@ if {[info tclversion] == 8.4} {
     }
 }
 
-if {[lsearch -exact $auto_path $dir] == -1} {
-    lappend auto_path $dir
-}
-
 if {[info exists tcl_platform(debug)]} {
     set file [file join $dir vfs10d[info sharedlibextension]]
 } else {
@@ -37,7 +33,16 @@ if {![file exists $file]} {
     return
 }
 
-package ifneeded vfs 1.0 [list load $file]
+proc loadvfs {file} {
+    global auto_path
+    set dir [file dirname $file]
+    if {[lsearch -exact $auto_path $dir] == -1} {
+	lappend auto_path $dir
+    }
+    load $file
+}
+
+package ifneeded vfs 1.0 [list loadvfs $file]
 unset file
 
 package ifneeded mk4vfs 1.0 [list source [file join $dir mk4vfs.tcl]]
diff --git a/tests/vfsArchive.test b/tests/vfsArchive.test
new file mode 100644
index 0000000..f2697e5
--- /dev/null
+++ b/tests/vfsArchive.test
@@ -0,0 +1,60 @@
+# Commands covered: running our tests from inside a 'zip' vfs.
+#
+# 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) 2001-2002 by Vince Darley.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest
+    namespace import ::tcltest::*
+}
+
+tcltest::testConstraint nativefs \
+  [string equal [lindex [file system [info script]] 0] "native"]
+
+proc makeAndMountZipArchive {} {
+    puts stdout "Zipping tests" ; update
+    cd [file dirname [file dirname [file normalize [info script]]]]
+    set filelist [concat [glob -dir [pwd] -join -tails tests *.test] \
+      [glob -dir [pwd] -join -tails tests *.tcl]]
+    catch {file delete [file join tests tests.zip]}
+    eval [list exec zip -q -9 [file join tests tests.zip]] $filelist
+    puts stdout "Done zipping"
+    cd [file dirname [info script]]
+    
+    package require vfs
+    set mount [vfs::zip::Mount tests.zip tests.zip]
+    cd tests.zip
+    return [list vfs::zip::Unmount $mount tests.zip]
+}
+
+# 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} {
+    set testdir [pwd]
+    puts stderr $testdir
+    package require vfs
+    if {[catch {makeAndMountZipArchive} unmount]} {
+	set res "Couldn't make zip archive to test with: $unmount"
+	puts stderr $::auto_path
+    } else {
+	cd tests
+	source all.tcl
+	cd ..
+	cd ..
+	puts [pwd]
+	eval $unmount
+	set res "ok"
+    }
+    cd $testdir
+    set res
+} {ok}
+
+
+
diff --git a/tests/vfsZip.test b/tests/vfsZip.test
index 738637c..ff3ed8f 100644
--- a/tests/vfsZip.test
+++ b/tests/vfsZip.test
@@ -15,36 +15,4 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
     namespace import ::tcltest::*
 }
 
-set dir [pwd]
-if {[catch {
-    puts stdout "Zipping tests" ; update
-    cd [file dirname [file dirname [file normalize [info script]]]]
-    foreach f [concat [glob -dir [pwd] -join -tails tests *.test] \
-      [glob -dir [pwd] -join -tails tests *.tcl]] {
-	if {[file tail $f] != "vfsZip.test"} {
-	    lappend filelist $f
-	}
-    }
-    catch {file delete [file join tests tests.zip]}
-    eval [list exec zip -q -9 [file join tests tests.zip]] $filelist
-    puts stdout "Done zipping"
-    cd [file dirname [info script]]
-    
-    package require vfs
-    set mount [vfs::zip::Mount tests.zip tests.zip]
-    cd tests.zip
-    cd tests
-    source all.tcl
-    vfs::zip::Unmount $mount tests.zip
-} err]} {
-    puts "vfsZip.test: running tests from a zip vfs failed"
-    global errorInfo
-    puts $errorInfo
-} else {
-    puts "vfsZip.test: running tests from a zip vfs succeeded"
-}
-
-puts "vfsZip.test: complete"
-cd $dir
-