From 355456674cce4400c85770b50b0f1dda6cbebb9a Mon Sep 17 00:00:00 2001 From: Jacob Bachmeyer Date: Thu, 29 Sep 2022 20:42:00 -0500 Subject: Add initial mockvfs support for internal unit tests --- ChangeLog | 6 + testsuite/runtest.libs/mockvfs.tcl | 261 +++++++++++++++++++++++++++++++++++++ 2 files changed, 267 insertions(+) create mode 100644 testsuite/runtest.libs/mockvfs.tcl diff --git a/ChangeLog b/ChangeLog index f8d5356..a0e9edc 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2022-09-29 Jacob Bachmeyer + + PR58065 + + * testsuite/runtest.libs/mockvfs.tcl: New file. + 2022-09-26 Jacob Bachmeyer * testsuite/runtest.libs/libs.exp (process_test): Add forward diff --git a/testsuite/runtest.libs/mockvfs.tcl b/testsuite/runtest.libs/mockvfs.tcl new file mode 100644 index 0000000..8064aa8 --- /dev/null +++ b/testsuite/runtest.libs/mockvfs.tcl @@ -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 -- cgit v1.1