Lines of
example/main.tcl
from check-in b502b175ea
that are changed by the sequence of edits moving toward
check-in 32bd347b13:
1: #! /usr/bin/env tclsh
2:
3: package require tcltest
4:
5: tcltest::testConstraint tcl87 [string match "8.7.*" [info patchlevel]]
6:
7: tcltest::configure -verbose pbse
8: tcltest::configure {*}$argv
9:
10: if {![info exists ::env(XVFS_ROOT_MOUNTPOINT)]} {
11: set xvfsRootMountpoint "//xvfs:/"
12: } else {
13: set xvfsRootMountpoint $::env(XVFS_ROOT_MOUNTPOINT)
14: }
15:
16: set rootDir "${xvfsRootMountpoint}example"
17: set rootDirNative [file join [pwd] example]
18: #set rootDir $rootDirNative
19: set testFile "${rootDir}/foo"
20:
21: proc glob_verify {args} {
22: set rv [glob -nocomplain -directory $::rootDir {*}$args]
23: set verify [glob -nocomplain -directory $::rootDirNative {*}$args]
24:
25: if {[llength $rv] != [llength $verify]} {
26: error "VERIFY FAILED: glob ... $args ($rv versus $verify)"
27: }
28:
29: return $rv
30: }
31:
32: proc test_summary {} {
33: set format "| %7s | %7s | %7s | %7s |"
34: set emptyRow [format $format "" "" "" ""]
35: set emptyRowLength [string length $emptyRow]
36: lappend output "/[string repeat - [expr {$emptyRowLength - 2}]]\\"
37: lappend output [format $format "Passed" "Failed" "Skipped" "Total"]
38: lappend output [regsub -all -- " " [regsub -all -- " \\| " $emptyRow " + "] "-"]
39: lappend output [format $format \
40: $::tcltest::numTests(Passed) \
41: $::tcltest::numTests(Failed) \
42: $::tcltest::numTests(Skipped) \
43: $::tcltest::numTests(Total) \
44: ]
45: lappend output "\\[string repeat - [expr {$emptyRowLength - 2}]]/"
46:
47: return [join $output "\n"]
48: }
49:
50: tcltest::customMatch boolean [list apply {{expected actual} {
51: if {!!$expected == !!$actual} {
52: return true
53: } else {
54: return false
55: }
56: }}]
57:
58: tcltest::test xvfs-seek-basic "Xvfs Seek Test" -setup {
59: set fd [open $testFile]
60: } -body {
61: seek $fd 0 end
62: seek $fd -1 current
63:
64: read $fd 1
65: } -cleanup {
66: close $fd
67: unset fd
68: } -result "\n"
69:
70: tcltest::test xvfs-seek-past-eof "Xvfs Seek Past EOF File Test" -setup {
71: set fd [open $testFile]
72: } -body {
73: seek $fd 1 end
74: } -cleanup {
75: close $fd
76: unset fd
77: } -match glob -returnCodes error -result "*: invalid argument"
78:
79: tcltest::test xvfs-seek-past-eof "Xvfs Seek Past EOF File Test" -setup {
80: set fd [open $testFile]
81: } -body {
82: seek $fd -10 current
83: } -cleanup {
84: close $fd
85: unset fd
86: } -match glob -returnCodes error -result "*: invalid argument"
87:
88: tcltest::test xvfs-seek-read-past-eof "Xvfs Seek Then Read Past EOF Test" -setup {
89: set fd [open $testFile]
90: } -body {
91: seek $fd 0 end
92:
93: read $fd 1
94: read $fd 1
95: } -cleanup {
96: close $fd
97: unset fd
98: } -result ""
99:
100: tcltest::test xvfs-basic-open-neg "Xvfs Open Non-Existant File Test" -body {
101: unset -nocomplain fd
102: set fd [open $rootDir/does-not-exist]
103: } -cleanup {
104: if {[info exists fd]} {
105: close $fd
106: unset fd
107: }
108: } -returnCodes error -result "no such file or directory"
109:
110: tcltest::test xvfs-basic-open-write "Xvfs Open For Writing Test" -body {
111: unset -nocomplain fd
112: set fd [open $rootDir/new-file w]
113: } -cleanup {
114: if {[info exists fd]} {
115: close $fd
116: unset fd
117: }
118: catch {
119: file delete $rootDir/new-file
120: }
121: } -match glob -returnCodes error -result "*read*only file*system*"
122:
123: tcltest::test xvfs-basic-open-directory "Xvfs Open Directory Test" -body {
124: unset -nocomplain fd
125: set fd [open $rootDir/lib]
126: set fd
127: } -cleanup {
128: if {[info exists fd]} {
129: close $fd
130: unset fd
131: }
132: } -match glob -returnCodes error -result "*illegal operation on a directory"
133:
134: tcltest::test xvfs-basic-two-files "Xvfs Multiple Open Files Test" -setup {
135: set fd1 [open $testFile]
136: set fd2 [open $testFile]
137: } -body {
138: set data1 [read $fd1]
139: close $fd1
140: set data2 [read $fd2]
141: close $fd2
142:
143: expr {$data1 eq $data2}
144: } -cleanup {
145: unset -nocomplain fd1 fd2 data1 data2
146: } -match boolean -result true
147:
148: tcltest::test xvfs-events "Xvfs Fileevent Test" -setup {
149: set fd [open $testFile]
150: seek $fd 0 end
151: set size [tell $fd]
152: seek $fd 0 start
153:
154: set done false
155: set calls 0
156: set output ""
157: } -body {
158: fileevent $fd readable [list apply {{fd} {
159: set pos [tell $fd]
160: set x [read $fd 1]
161: if {[string length $x] == 0} {
162: set ::done true
163: fileevent $fd readable ""
164: }
165:
166: lappend ::output $pos
167: incr ::calls
168: }} $fd]
169: vwait done
170:
171: list [expr {$calls == ($size + 1)}] [expr {[lsort -integer $output] eq $output}]
172: } -cleanup {
173: close $fd
174: update
175: unset -nocomplain fd size done calls output
176: } -result {1 1}
177:
178: tcltest::test xvfs-match-almost-root-neg "Xvfs Match Almost Root" -body {
179: file exists ${rootDir}_DOES_NOT_EXIST
180: } -match boolean -result false
181:
182: tcltest::test xvfs-glob-basic-any "Xvfs Glob Match Any Test" -body {
183: llength [glob_verify *]
184: } -result 3
185:
186: tcltest::test xvfs-glob-files-any "Xvfs Glob Match Any File Test" -body {
187: llength [glob_verify -type f *]
188: } -result 2
189:
190: tcltest::test xvfs-glob-dir-any "Xvfs Glob On a File Test" -body {
191: glob -nocomplain -directory $testFile *
192: } -returnCodes error -result "not a directory"
193:
194: tcltest::test xvfs-glob-basic-limited "Xvfs Glob Match Limited Test" -body {
195: llength [glob_verify f*]
196: } -result 1
197:
198: tcltest::test xvfs-glob-basic-limited-neg "Xvfs Glob Match Limited Negative Test" -body {
199: llength [glob_verify x*]
200: } -result 0
201:
202: tcltest::test xvfs-glob-basic-limited-prefixed "Xvfs Glob Match Limited But With Directory Prefix Test" -body {
203: llength [glob_verify ./f*]
204: } -result 1
205:
206: tcltest::test xvfs-glob-basic-limited-and-typed-prefixed "Xvfs Glob Match Limited Path and Type Positive Test" -body {
207: llength [glob_verify -type f ./f*]
208: } -result 1
209:
210: tcltest::test xvfs-glob-basic-limited-and-typed-prefixed-neg "Xvfs Glob Match Limited Path and Type Negative Test" -body {
211: llength [glob_verify -type d ./f*]
212: } -result 0
213:
214: tcltest::test xvfs-glob-basic-limited-prefixed-other-dir-1 "Xvfs Glob Match Directory Included in Search Test (Count)" -body {
215: llength [glob_verify lib/*]
216: } -result 1
217:
218: tcltest::test xvfs-glob-basic-limited-prefixed-other-dir-2 "Xvfs Glob Match Directory Included in Search Test (Value)" -body {
219: lindex [glob_verify lib/*] 0
220: } -match glob -result "$rootDir/*"
221:
222: tcltest::test xvfs-glob-no-dir "Xvfs Glob Non-Existant Directory Test" -body {
223: glob_verify libx/*
224: } -returnCodes error -result "no such file or directory"
225:
226: tcltest::test xvfs-glob-pipes "Xvfs Glob Pipes Test " -body {
227: glob_verify -types {p b c s l} lib/*
228: } -result ""
229:
230: tcltest::test xvfs-glob-writable "Xvfs Glob Writable Test " -body {
231: glob -nocomplain -directory $rootDir -types w *
232: } -result ""
233:
234: tcltest::test xvfs-glob-hidden "Xvfs Glob Hidden Test " -body {
235: glob -nocomplain -directory $rootDir -types hidden *
236: } -result ""
237:
238: tcltest::test xvfs-glob-executable "Xvfs Glob Executable Test " -body {
239: glob -nocomplain -directory $rootDir -types x *
240: } -result $rootDir/lib
241:
242: tcltest::test xvfs-glob-trailing-slash-1 "Xvfs Glob Trailing Slash Test" -body {
243: llength [glob -nocomplain -directory $rootDir/ *]
244: } -result 3
245:
246: tcltest::test xvfs-access-basic-read "Xvfs acccess Read Basic Test" -body {
247: file readable $testFile
248: } -match boolean -result true
249:
250: tcltest::test xvfs-access-basic-write "Xvfs acccess Write Basic Test" -body {
251: file writable $testFile
252: } -match boolean -result false
253:
254: tcltest::test xvfs-access-basic-neg "Xvfs acccess Basic Negative Test" -body {
255: file executable $testFile
256: } -match boolean -result false
257:
258: tcltest::test xvfs-access-similar-neg "Xvfs acccess Similar Negative Test" -body {
259: file executable ${rootDir}_DOES_NOT_EXIST
260: } -match boolean -result false
261:
262: tcltest::test xvfs-exists-basic-neg "Xvfs exists Basic Negative Test" -body {
263: file exists $rootDir/does-not-exist
264: } -match boolean -result false
265:
266: tcltest::test xvfs-stat-basic-file "Xvfs stat Basic File Test" -body {
267: file stat $testFile fileInfo
268: set fileInfo(type)
269: } -cleanup {
270: unset -nocomplain fileInfo
271: } -result file
272:
273: tcltest::test xvfs-stat-basic-file-neg "Xvfs stat Basic File Negative Test" -body {
274: file stat $rootDir/does-not-exist fileInfo
275: } -cleanup {
276: unset -nocomplain fileInfo
277: } -match glob -returnCodes error -result "*no such file or directory"
278:
279: tcltest::test xvfs-stat-basic-dir "Xvfs stat Basic Directory Test" -body {
280: file stat $rootDir/lib fileInfo
281: set fileInfo(type)
282: } -cleanup {
283: unset -nocomplain fileInfo
284: } -result directory
285:
286: # Broken in Tcl 8.6 and earlier
287: tcltest::test xvfs-glob-advanced-dir-with-pattern "Xvfs Glob Match Pattern and Directory Together" -body {
288: llength [glob ${rootDir}/*]
289: } -constraints tcl87 -result 3
290:
291: tcltest::test xvfs-glob-file-dirname "Xvfs Relies on file dirname" -body {
292: lindex [glob -directory [file dirname $testFile] *] 0
293: } -constraints tcl87 -match glob -result "$rootDir/*"
294:
295: tcltest::test xvfs-cwd-1 "Xvfs Can Be cwd" -setup {
296: set startDir [pwd]
297: } -body {
298: cd $rootDir
299: pwd
300: } -cleanup {
301: cd $startDir
302: unset startDir
303: } -constraints tcl87 -result $rootDir
304:
305: tcltest::test xvfs-cwd-2 "Xvfs Can Be cwd" -setup {
306: set startDir [pwd]
307: } -body {
308: cd $rootDir
309: cd lib
310: lindex [glob *] 0
311: } -cleanup {
312: cd $startDir
313: unset startDir
314: } -constraints tcl87 -result "hello"
315:
316: # Currently broken
317: tcltest::test xvfs-package "Xvfs Can Be Package Directory" -setup {
318: set startAutoPath $auto_path
319: lappend auto_path ${rootDir}/lib
320: } -body {
321: package require hello
322: set auto_path
323: } -cleanup {
324: set auto_path $startAutoPath
325: unset startAutoPath
326: } -constraints knownBug -result ""
327:
328: # Output results
329: if {$::tcltest::numTests(Failed) != 0} {
330: puts [test_summary]
331: if {[info exists ::env(XVFS_TEST_EXIT_ON_FAILURE)]} {
332: exit $::env(XVFS_TEST_EXIT_ON_FAILURE)
333: }
334: exit 1
335: }
336:
337: puts [test_summary]
338: puts "ALL TESTS PASSED"
339:
340: if {[info exists ::env(XVFS_TEST_EXIT_ON_SUCCESS)]} {
341: exit $::env(XVFS_TEST_EXIT_ON_SUCCESS)
342: }
343: exit 0