testsuite/runtest.libs/mockvfs.tcl

   1 # Copyright (C) 2022 Free Software Foundation, Inc.
   2 #
   3 # This file is part of DejaGnu.
   4 #
   5 # DejaGnu is free software: you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation, either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # DejaGnu is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with DejaGnu.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 # This file was written by Jacob Bachmeyer.
  19
  20 # This library provides convenience procedures for emulating a partial
  21 # filesystem while running isolated tests of DejaGnu procedures in a slave
  22 # interpreter.  These are designed to be run in the child process used by
  23 # the DejaGnu library tests.  Intended use is with mockutil.tcl.
  24
  25 # This implementation is by no means complete, but is sufficient for the
  26 # purposes of internal DejaGnu unit tests and will be expanded as needed.
  27
  28 proc create_mockvfs { vfsname } {
  29     upvar #0 $vfsname vfs
  30
  31     array unset vfs
  32     array set vfs {
  33         chan,hint 1
  34     }
  35 }
  36
  37 # create_mock_file vfsname {filename contents}...
  38 proc create_mock_file { vfsname args } {
  39     upvar #0 $vfsname vfs
  40
  41     foreach {filename contents} $args {
  42         if { [regexp -- {\A\n\s+} $contents indent] } {
  43             regsub "\\A$indent" $contents "" contents
  44             regsub -all -- $indent $contents "\n" contents
  45             regsub {\n\s+\Z} $contents "\n" contents
  46         }
  47         set vfs(file,data,$filename) $contents
  48         set vfs(file,length,$filename) [string length $contents]
  49     }
  50 }
  51
  52 # Install mockvfs procedure aliases in slave interpreter
  53 proc attach_mockvfs { sicmd vfsname } {
  54     # supply operations for file name operations
  55     foreach cmd { file glob open } {
  56         $sicmd alias $cmd "mockvfs_op_${cmd}" $vfsname $sicmd
  57     }
  58     # override I/O channel-using commands present in a safe interpreter
  59     foreach cmd {
  60         close eof flush gets puts read seek tell
  61     } {
  62         $sicmd hide $cmd
  63         $sicmd alias $cmd "mockvfs_op_${cmd}" $vfsname $sicmd
  64     }
  65     # DejaGnu uses Expect instead of the Tcl event loop at this time, so
  66     #  fconfigure, fcopy, and fileevent are left untouched for now.
  67     # The mock VFS does not have a current directory, so cd is omitted.
  68 }
  69
  70 # operations normally not available in safe interpreters:
  71 proc mockvfs_op_file    { vfsname sicmd op args } {
  72     upvar #0 $vfsname vfs
  73
  74     switch -- $op {
  75         dirname {
  76             set name [lindex $args 0]
  77             set point [string last / $name]
  78             if { $point == -1 } { return . }
  79             return [string range $name 0 [expr {$point-1}]]
  80         }
  81         tail {
  82             set name [lindex $args 0]
  83             set point [string last / $name]
  84             if { $point == -1 } { return $name }
  85             return [string range $name [expr {$point+1}] end]
  86         }
  87         default {
  88             error "mockvfs: file $op not implemented"
  89         }
  90     }
  91 }
  92 proc mockvfs_op_glob    { vfsname sicmd args } {
  93     upvar #0 $vfsname vfs
  94
  95     error "mockvfs: glob not implemented"
  96 }
  97 proc mockvfs_op_open    { vfsname sicmd
  98                           fileName {access r} {permissions 0666} } {
  99     upvar #0 $vfsname vfs
 100
 101     if { ! [info exists vfs(file,data,$fileName)] } {
 102         error "couldn't open \"$fileName\": no such file or directory"
 103     }
 104
 105     switch -glob -- $access {
 106         ?+      -
 107         [wa]*   -
 108         *WR*    { error "couldn't open \"$fileName\": read-only file system" }
 109     }
 110
 111     set fnum $vfs(chan,hint)
 112     while { [info exists vfs(chan,mock${fnum},pos)] } { incr fnum }
 113     set vfs(chan,hint) $fnum
 114     set handle mock${fnum}
 115     set vfs(chan,$handle,pos) 0
 116     set vfs(chan,$handle,file) $fileName
 117
 118     return $handle
 119 }
 120
 121 # operations normally available in safe interpreters:
 122 proc mockvfs_op_close   { vfsname sicmd chan } {
 123     if { ! [string match mock* $chan] } {
 124         return [$sicmd invokehidden close $chan]
 125     }
 126
 127     upvar #0 $vfsname vfs
 128
 129     if { [info exists vfs(chan,$chan,pos)] } {
 130         array unset vfs chan,$chan,*
 131         scan $chan mock%d fnum
 132         if { $vfs(chan,hint) > $fnum } { set vfs(chan,hint) $fnum }
 133     } else {
 134         error "can not find channel named \"$chan\""
 135     }
 136 }
 137 proc mockvfs_op_eof     { vfsname sicmd chan } {
 138     if { ! [string match mock* $chan] } {
 139         return [$sicmd invokehidden eof $chan]
 140     }
 141
 142     upvar #0 $vfsname vfs
 143
 144     if { ! [info exists vfs(chan,$chan,pos)] } {
 145         error "can not find channel named \"$chan\""
 146     }
 147
 148     if { $vfs(chan,$chan,pos) >= $vfs(file,length,$vfs(chan,$chan,file)) } {
 149         return 1
 150     } else {
 151         return 0
 152     }
 153 }
 154 proc mockvfs_op_flush   { vfsname sicmd chan } {
 155     if { ! [string match mock* $chan] } {
 156         return [$sicmd invokehidden flush $chan]
 157     }
 158     # do nothing for mockvfs channels
 159 }
 160 proc mockvfs_op_gets    { vfsname sicmd chan args } {
 161     if { ! [string match mock* $chan] } {
 162         return [eval [list $sicmd invokehidden gets] $args]
 163     }
 164
 165     upvar #0 $vfsname vfs
 166     if { [llength $args] > 1 } {
 167         error "too many arguments to gets: gets $chan $args"
 168     } elseif { [llength $args] == 1 } {
 169         set outvar [lindex $args 0]
 170     }
 171
 172     if { ! [info exists vfs(chan,$chan,pos)] } {
 173         error "can not find channel named \"$chan\""
 174     }
 175
 176     if { $vfs(chan,$chan,pos) >= $vfs(file,length,$vfs(chan,$chan,file)) } {
 177         # at EOF
 178         set output ""
 179         set outcnt -1
 180     } else {
 181         set bound [string first "\n" $vfs(file,data,$vfs(chan,$chan,file)) \
 182                        $vfs(chan,$chan,pos)]
 183         if { $bound == -1 } {
 184             # no newline found before eof; return last partial line
 185             set output [string range $vfs(file,data,$vfs(chan,$chan,file)) \
 186                             $vfs(chan,$chan,pos) end]
 187             set outcnt [string length $output]
 188             set vfs(chan,$chan,pos) $vfs(file,length,$vfs(chan,$chan,file))
 189         } else {
 190             # return a full line
 191             set output [string range $vfs(file,data,$vfs(chan,$chan,file)) \
 192                             $vfs(chan,$chan,pos) [expr {$bound-1}]]
 193             set outcnt [string length $output]
 194             incr vfs(chan,$chan,pos) [expr {1+$outcnt}]
 195         }
 196     }
 197
 198     if { [info exists outvar] } {
 199         $sicmd eval [list set $outvar $output]
 200         return $outcnt
 201     } else {
 202         return $output
 203     }
 204 }
 205 proc mockvfs_op_read    { vfsname sicmd chan args } {
 206     if { ! [string match mock* $chan] } {
 207         return [eval [list $sicmd invokehidden read] $args]
 208     }
 209
 210     upvar #0 $vfsname vfs
 211
 212     if { ! [info exists vfs(chan,$chan,pos)] } {
 213         error "can not find channel named \"$chan\""
 214     }
 215
 216     error "mockvfs: read not implemented"
 217 }
 218 proc mockvfs_op_puts    { vfsname sicmd args } {
 219     if { [llength $args] < 2
 220          || ! [string match mock* [lindex $args end-1]] } {
 221         return [eval [list $sicmd invokehidden puts] $args]
 222     }
 223
 224     upvar #0 $vfsname vfs
 225
 226     if { ! [info exists vfs(chan,$chan,pos)] } {
 227         error "can not find channel named \"$chan\""
 228     }
 229
 230     error "mockvfs is currently read-only"
 231 }
 232 proc mockvfs_op_seek    { vfsname sicmd chan args } {
 233     if { ! [string match mock* $chan] } {
 234         return [eval [list $sicmd invokehidden seek] $args]
 235     }
 236
 237     upvar #0 $vfsname vfs
 238
 239     if { ! [info exists vfs(chan,$chan,pos)] } {
 240         error "can not find channel named \"$chan\""
 241     }
 242
 243     error "mockvfs: seek not implemented"
 244 }
 245 proc mockvfs_op_tell    { vfsname sicmd chan args } {
 246     if { ! [string match mock* $chan] } {
 247         return [eval [list $sicmd invokehidden tell] $args]
 248     }
 249
 250     upvar #0 $vfsname vfs
 251
 252     if { ! [info exists vfs(chan,$chan,pos)] } {
 253         error "can not find channel named \"$chan\""
 254     }
 255
 256     error "mockvfs: tell not implemented"
 257 }
 258
 259
 260 #EOF