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