1# Commands covered: running our tests from inside a 'zip' vfs. 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright (c) 2001-2002 by Vince Darley. 8# 9# See the file "license.terms" for information on usage and redistribution 10# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11# 12 13if {[lsearch [namespace children] ::tcltest] == -1} { 14 package require tcltest 15 namespace import ::tcltest::* 16} 17 18tcltest::testConstraint nativefs \ 19 [string equal [lindex [file system [info script]] 0] "native"] 20 21proc makeAndMountZipArchive {} { 22 puts stdout "Zipping tests" ; update 23 cd [file dirname [file dirname [file normalize [info script]]]] 24 set filelist [concat [glob -dir [pwd] -join -tails tests *.test] \ 25 [glob -dir [pwd] -join -tails tests *.tcl]] 26 catch {file delete [file join tests tests.zip]} 27 eval [list exec zip -q -9 [file join tests tests.zip]] $filelist 28 puts stdout "Done zipping" 29 cd [file dirname [info script]] 30 31 package require vfs::zip 32 set mount [vfs::zip::Mount tests.zip tests.zip] 33 #puts "[pwd] ; $::auto_path, [glob *]" 34 pwd 35 cd tests.zip 36 return [list vfs::zip::Unmount $mount tests.zip] 37} 38 39proc makeAndMountMk4Archive {} { 40 puts stdout "Making mk4 archive of tests" ; update 41 cd [file dirname [file dirname [file normalize [info script]]]] 42 catch {file delete [file join tests tests.bin]} 43 exec sdx fs2sd tests 44 puts stdout "Done making mk4 archive" 45 cd [file dirname [info script]] 46 47 package require vfs::mk4 48 set mount [vfs::mk4::Mount tests.bin tests.bin] 49 cd tests.bin 50 return [list vfs::mk4::Unmount $mount tests.bin] 51} 52 53# This actually calls the test suite recursively, which probably 54# causes some problems, although it shouldn't really! 55test vfsArchive-1.0 {package require vfs} { 56 if {![catch {package require vfs} res]} { 57 set res "ok" 58 } 59 set res 60} {ok} 61 62# This actually calls the test suite recursively, which probably 63# causes some problems, although it shouldn't really! 64test vfsArchive-1.1 {run tests in zip archive} {nativefs} { 65 # If this test fails, you probably don't have 'zip' installed. 66 set testdir [pwd] 67 package require vfs 68 if {[catch {makeAndMountZipArchive} unmount]} { 69 set res "Couldn't make and mount zip archive to test with: $unmount" 70 puts $::errorInfo 71 puts stderr $::auto_path 72 } else { 73 puts stdout "=== Running tests in zip archive ===" 74 if {![catch { 75 cd tests 76 source all.tcl 77 cd .. 78 cd .. 79 puts [pwd] 80 eval $unmount 81 } res]} { 82 set res "ok" 83 } 84 puts stdout "=== End of embedded zip tests ===" 85 } 86 cd $testdir 87 set res 88} {ok} 89 90 91# This actually calls the test suite recursively, which probably 92# causes some problems, although it shouldn't really! 93test vfsArchive-1.2 {run tests in mk4 archive} {nativefs} { 94 # If this test fails, you probably don't have tclkit and 'sdx' 95 # installed. That's not a big deal. 96 set testdir [pwd] 97 puts stderr $testdir 98 package require vfs 99 if {[catch {makeAndMountMk4Archive} unmount]} { 100 set res "Couldn't make and mount mk4 archive to test with: $unmount" 101 puts stderr $::auto_path 102 } else { 103 puts stdout "=== Running tests in mk4 archive ===" 104 cd tests 105 source all.tcl 106 cd .. 107 cd .. 108 puts [pwd] 109 eval $unmount 110 set res "ok" 111 puts stdout "=== End of embedded mk4 tests ===" 112 } 113 cd $testdir 114 set res 115} {ok} 116 117 118 119