From 7c1270b4939c7f18f8f69eabc2ff56f59380e59d Mon Sep 17 00:00:00 2001 From: Vince Darley Date: Tue, 7 May 2002 08:41:56 +0000 Subject: [PATCH] better tests --- ChangeLog | 11 ++++++++ library/pkgIndex.tcl | 15 +++++++---- tests/vfsArchive.test | 60 +++++++++++++++++++++++++++++++++++++++++++ tests/vfsZip.test | 32 ----------------------- 4 files changed, 81 insertions(+), 37 deletions(-) create mode 100644 tests/vfsArchive.test diff --git a/ChangeLog b/ChangeLog index b28f225..990b057 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2002-05-03 Vince Darley + * 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 * 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 - -- 2.23.0