1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
# Commands covered: vfs::filesystem
#
# 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::*
}
package require vfs
proc filelistrelative {filelist {remove ""}} {
if {[llength $remove]} {
set newlist {}
foreach f $filelist {
if {[lsearch -exact $remove $f] == -1} {
lappend newlist $f
}
}
set filelist $newlist
}
set dir [file normalize [pwd]]
set len [string length $dir]
incr len
set res {}
foreach d $filelist {
if {[string first $dir $d] == 0} {
lappend res [string range $d $len end]
} else {
lappend res $d
}
}
set res
}
test vfs-1.1 {mount unmount} {
catch {unset res}
vfs::filesystem mount foo bar
set res [list [catch {vfs::filesystem unmount foo bar} err]]
lappend res $err
vfs::filesystem unmount foo
unset err
set res
} {1 {wrong # args: should be "vfs::filesystem unmount path"}}
# Test 2.x sub-interps
test vfs-2.1 {mount unmount in sub interp} {
catch {interp delete a}
catch {unset res}
set remove [vfs::filesystem info]
vfs::filesystem mount foo bar
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
eval lappend res [vfs::filesystem info]
vfs::filesystem unmount foo
filelistrelative $res $remove
} {foo2 foo foo}
test vfs-2.2 {mount, delete sub interp} {
catch {interp delete a}
catch {unset res}
set remove [vfs::filesystem info]
vfs::filesystem mount foo bar
vfsCreateInterp a
a eval {package require vfs}
a eval {vfs::filesystem mount foo2 bar2}
set res {}
eval lappend res [vfs::filesystem info]
interp delete a
eval lappend res [vfs::filesystem info]
vfs::filesystem unmount foo
filelistrelative $res $remove
} {foo2 foo foo}
test vfs-3.1 {vfs helpers: in memory channels} {
close [::vfs::memchan]
# If we get here, it's ok. If this test fails,
# probably many other tests will fail too. In particular
# any use of 'open', 'source', 'load', and usually also
# 'file copy', 'file rename' in a vfs will fail.
#
# What this means is that tclvfs can't find some other
# extension/code it requires -- you may need to install
# the Memchan or Rchan extension for example.
} {}
test vfs-3.2 {vfs helpers: crc} {
# If this test fails, probably many other tests will fail too (at
# least anything to do with 'zip' vfs).
#
# What this means is that tclvfs can't find some other
# extension/code it requires -- you may need to install
# the Trf extension for example.
::vfs::crc abcd
} {Kc*}
test vfs-3.3 {vfs helpers: zip} {
# If this test fails, probably many other tests will fail too (at
# least anything to do with 'zip' vfs).
#
# What this means is that tclvfs can't find some other
# extension/code it requires -- you may need to install
# the Try extension for example.
::vfs::zip -mode compress 1234567890
} "\x78\x9c\x33\x34\x32\x36\x31\x35\x33\xb7\xb0\x34\x0\x0\xb\x2c\x2\xe"
test vfs-3.4 {vfs helpers: zip} {
# If this test fails, probably many other tests will fail too (at
# least anything to do with 'zip' vfs).
#
# What this means is that tclvfs can't find some other
# extension/code it requires -- you may need to install
# the Try extension for example.
::vfs::zip -mode decompress "\x78\x9c\x33\x34\x32\x36\x31\x35\x33\xb7\xb0\x34\x0\x0\xb\x2c\x2\xe"
} {1234567890}
# cleanup
::tcltest::cleanupTests
return
|
