From c53de1eca48876459a19933879bc76597cc0d8c1 Mon Sep 17 00:00:00 2001 From: Vince Darley Date: Tue, 20 Jan 2004 15:25:14 +0000 Subject: [PATCH] test suite overhaul --- library/pkgIndex.tcl | 10 ++++- tests/all.tcl | 94 ++++++++++++++++++++++++++++++++++++++++++- tests/vfs.test | 6 +-- tests/vfsArchive.test | 36 ++++++++++++----- 4 files changed, 130 insertions(+), 16 deletions(-) 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 -- 2.23.0