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