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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
|
# Copyright (C) 2022 Free Software Foundation, Inc.
#
# This file is part of DejaGnu.
#
# DejaGnu is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# DejaGnu is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with DejaGnu; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.
# This file was written by Jacob Bachmeyer.
# This library provides convenience procedures for emulating a partial
# filesystem while running isolated tests of DejaGnu procedures in a slave
# interpreter. These are designed to be run in the child process used by
# the DejaGnu library tests. Intended use is with mockutil.tcl.
# This implementation is by no means complete, but is sufficient for the
# purposes of internal DejaGnu unit tests and will be expanded as needed.
proc create_mockvfs { vfsname } {
upvar #0 $vfsname vfs
array unset vfs
array set vfs {
chan,hint 1
}
}
# create_mock_file vfsname {filename contents}...
proc create_mock_file { vfsname args } {
upvar #0 $vfsname vfs
foreach {filename contents} $args {
if { [regexp -- {\A\n\s+} $contents indent] } {
regsub "\\A$indent" $contents "" contents
regsub -all -- $indent $contents "\n" contents
regsub {\n\s+\Z} $contents "\n" contents
}
set vfs(file,data,$filename) $contents
set vfs(file,length,$filename) [string length $contents]
}
}
# Install mockvfs procedure aliases in slave interpreter
proc attach_mockvfs { sicmd vfsname } {
# supply operations for file name operations
foreach cmd { file glob open } {
$sicmd alias $cmd "mockvfs_op_${cmd}" $vfsname $sicmd
}
# override I/O channel-using commands present in a safe interpreter
foreach cmd {
close eof flush gets puts read seek tell
} {
$sicmd hide $cmd
$sicmd alias $cmd "mockvfs_op_${cmd}" $vfsname $sicmd
}
# DejaGnu uses Expect instead of the Tcl event loop at this time, so
# fconfigure, fcopy, and fileevent are left untouched for now.
# The mock VFS does not have a current directory, so cd is omitted.
}
# operations normally not available in safe interpreters:
proc mockvfs_op_file { vfsname sicmd op args } {
upvar #0 $vfsname vfs
switch -- $op {
dirname {
set name [lindex $args 0]
set point [string last / $name]
if { $point == -1 } { return . }
return [string range $name 0 [expr {$point-1}]]
}
tail {
set name [lindex $args 0]
set point [string last / $name]
if { $point == -1 } { return $name }
return [string range $name [expr {$point+1}] end]
}
default {
error "mockvfs: file $op not implemented"
}
}
}
proc mockvfs_op_glob { vfsname sicmd args } {
upvar #0 $vfsname vfs
error "mockvfs: glob not implemented"
}
proc mockvfs_op_open { vfsname sicmd
fileName {access r} {permissions 0666} } {
upvar #0 $vfsname vfs
if { ! [info exists vfs(file,data,$fileName)] } {
error "couldn't open \"$fileName\": no such file or directory"
}
switch -glob -- $access {
?+ -
[wa]* -
*WR* { error "couldn't open \"$fileName\": read-only file system" }
}
set fnum $vfs(chan,hint)
while { [info exists vfs(chan,mock${fnum},pos)] } { incr fnum }
set vfs(chan,hint) $fnum
set handle mock${fnum}
set vfs(chan,$handle,pos) 0
set vfs(chan,$handle,file) $fileName
return $handle
}
# operations normally available in safe interpreters:
proc mockvfs_op_close { vfsname sicmd chan } {
if { ! [string match mock* $chan] } {
return [$sicmd invokehidden close $chan]
}
upvar #0 $vfsname vfs
if { [info exists vfs(chan,$chan,pos)] } {
array unset vfs chan,$chan,*
scan $chan mock%d fnum
if { $vfs(chan,hint) > $fnum } { set vfs(chan,hint) $fnum }
} else {
error "can not find channel named \"$chan\""
}
}
proc mockvfs_op_eof { vfsname sicmd chan } {
if { ! [string match mock* $chan] } {
return [$sicmd invokehidden eof $chan]
}
upvar #0 $vfsname vfs
if { ! [info exists vfs(chan,$chan,pos)] } {
error "can not find channel named \"$chan\""
}
if { $vfs(chan,$chan,pos) >= $vfs(file,length,$vfs(chan,$chan,file)) } {
return 1
} else {
return 0
}
}
proc mockvfs_op_flush { vfsname sicmd chan } {
if { ! [string match mock* $chan] } {
return [$sicmd invokehidden flush $chan]
}
# do nothing for mockvfs channels
}
proc mockvfs_op_gets { vfsname sicmd chan args } {
if { ! [string match mock* $chan] } {
return [eval [list $sicmd invokehidden gets] $args]
}
upvar #0 $vfsname vfs
if { [llength $args] > 1 } {
error "too many arguments to gets: gets $chan $args"
} elseif { [llength $args] == 1 } {
set outvar [lindex $args 0]
}
if { ! [info exists vfs(chan,$chan,pos)] } {
error "can not find channel named \"$chan\""
}
if { $vfs(chan,$chan,pos) >= $vfs(file,length,$vfs(chan,$chan,file)) } {
# at EOF
set output ""
set outcnt -1
} else {
set bound [string first "\n" $vfs(file,data,$vfs(chan,$chan,file)) \
$vfs(chan,$chan,pos)]
if { $bound == -1 } {
# no newline found before eof; return last partial line
set output [string range $vfs(file,data,$vfs(chan,$chan,file)) \
$vfs(chan,$chan,pos) end]
set outcnt [string length $output]
set vfs(chan,$chan,pos) $vfs(file,length,$vfs(chan,$chan,file))
} else {
# return a full line
set output [string range $vfs(file,data,$vfs(chan,$chan,file)) \
$vfs(chan,$chan,pos) [expr {$bound-1}]]
set outcnt [string length $output]
incr vfs(chan,$chan,pos) [expr {1+$outcnt}]
}
}
if { [info exists outvar] } {
$sicmd eval [list set $outvar $output]
return $outcnt
} else {
return $output
}
}
proc mockvfs_op_read { vfsname sicmd chan args } {
if { ! [string match mock* $chan] } {
return [eval [list $sicmd invokehidden read] $args]
}
upvar #0 $vfsname vfs
if { ! [info exists vfs(chan,$chan,pos)] } {
error "can not find channel named \"$chan\""
}
error "mockvfs: read not implemented"
}
proc mockvfs_op_puts { vfsname sicmd args } {
if { [llength $args] < 2
|| ! [string match mock* [lindex $args end-1]] } {
return [eval [list $sicmd invokehidden puts] $args]
}
upvar #0 $vfsname vfs
if { ! [info exists vfs(chan,$chan,pos)] } {
error "can not find channel named \"$chan\""
}
error "mockvfs is currently read-only"
}
proc mockvfs_op_seek { vfsname sicmd chan args } {
if { ! [string match mock* $chan] } {
return [eval [list $sicmd invokehidden seek] $args]
}
upvar #0 $vfsname vfs
if { ! [info exists vfs(chan,$chan,pos)] } {
error "can not find channel named \"$chan\""
}
error "mockvfs: seek not implemented"
}
proc mockvfs_op_tell { vfsname sicmd chan args } {
if { ! [string match mock* $chan] } {
return [eval [list $sicmd invokehidden tell] $args]
}
upvar #0 $vfsname vfs
if { ! [info exists vfs(chan,$chan,pos)] } {
error "can not find channel named \"$chan\""
}
error "mockvfs: tell not implemented"
}
#EOF
|
