← Back to branch summary

~ubuntu-branches/ubuntu/oneiric/tclvfs/oneiric

« back to all changes in this revision

Viewing changes to tests/vfsArchive.test

  • Committer: Bazaar Package Importer
  • Author(s): David N. Welton
  • Date: 2003-08-05 18:47:26 UTC
  • Revision ID: james.westby@ubuntu.com-20030805184726-bw2c591agyy9z96u
Tags: upstream-1.2.1
Import upstream version 1.2.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
tests/vfsArchive.test
 
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
 
 
13
if {[lsearch [namespace children] ::tcltest] == -1} {
 
14
    package require tcltest
 
15
    namespace import ::tcltest::*
 
16
}
 
17
 
 
18
tcltest::testConstraint nativefs \
 
19
  [string equal [lindex [file system [info script]] 0] "native"]
 
20
 
 
21
proc 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
    cd tests.zip
 
34
    return [list vfs::zip::Unmount $mount tests.zip]
 
35
}
 
36
 
 
37
proc makeAndMountMk4Archive {} {
 
38
    puts stdout "Making mk4 archive of tests" ; update
 
39
    cd [file dirname [file dirname [file normalize [info script]]]]
 
40
    catch {file delete [file join tests tests.bin]}
 
41
    exec sdx fs2sd tests
 
42
    puts stdout "Done making mk4 archive"
 
43
    cd [file dirname [info script]]
 
44
    
 
45
    package require vfs::mk4
 
46
    set mount [vfs::mk4::Mount tests.bin tests.bin]
 
47
    cd tests.bin
 
48
    return [list vfs::mk4::Unmount $mount tests.bin]
 
49
}
 
50
 
 
51
# This actually calls the test suite recursively, which probably
 
52
# causes some problems, although it shouldn't really!
 
53
test vfsArchive-1.1 {run tests in zip archive} {nativefs} {
 
54
    # If this test fails, you probably don't have 'zip' installed.
 
55
    set testdir [pwd]
 
56
    puts stderr $testdir
 
57
    package require vfs
 
58
    if {[catch {makeAndMountZipArchive} unmount]} {
 
59
        set res "Couldn't make zip archive to test with: $unmount"
 
60
        puts stderr $::auto_path
 
61
    } else {
 
62
        cd tests
 
63
        source all.tcl
 
64
        cd ..
 
65
        cd ..
 
66
        puts [pwd]
 
67
        eval $unmount
 
68
        set res "ok"
 
69
    }
 
70
    cd $testdir
 
71
    set res
 
72
} {ok}
 
73
 
 
74
 
 
75
# This actually calls the test suite recursively, which probably
 
76
# causes some problems, although it shouldn't really!
 
77
test vfsArchive-1.2 {run tests in mk4 archive} {nativefs} {
 
78
    # If this test fails, you probably don't have tclkit and 'sdx'
 
79
    # installed.  That's not a big deal.
 
80
    set testdir [pwd]
 
81
    puts stderr $testdir
 
82
    package require vfs
 
83
    if {[catch {makeAndMountMk4Archive} unmount]} {
 
84
        set res "Couldn't make mk4 archive to test with: $unmount"
 
85
        puts stderr $::auto_path
 
86
    } else {
 
87
        cd tests
 
88
        source all.tcl
 
89
        cd ..
 
90
        cd ..
 
91
        puts [pwd]
 
92
        eval $unmount
 
93
        set res "ok"
 
94
    }
 
95
    cd $testdir
 
96
    set res
 
97
} {ok}
 
98
 
 
99
 
 
100