riscv
/
dejagnu
mirror of https://gitee.com/Nocallback/dejagnu.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

Add initial mockvfs support for internal unit tests

master
Jacob Bachmeyer 4 years ago
parent
369c52e5c8
commit
355456674c
2 changed files with 267 additions and 0 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 6
      ChangeLog
  2. 261
      testsuite/runtest.libs/mockvfs.tcl

6
ChangeLog
View File

@ -1,3 +1,9 @@
2022-09-29 Jacob Bachmeyer <jcb@gnu.org>
PR58065
* testsuite/runtest.libs/mockvfs.tcl: New file.
2022-09-26 Jacob Bachmeyer <jcb@gnu.org>
* testsuite/runtest.libs/libs.exp (process_test): Add forward

261
testsuite/runtest.libs/mockvfs.tcl
View File

@ -0,0 +1,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
Write Preview
Loading…
Cancel
Save