1# Remnants of what used to be VFS init. This uses either the 8.6 core zlib 2# command or the tclkit zlib package with rechan to provide a memory channel 3# and a streaming decompression channel transform. 4 5package require Tcl 8.4; # vfs is all new for 8.4 6package provide vfslib 1.4 7 8# use zlib to define zip and crc if available 9if {[llength [info command zlib]] || ![catch {load "" zlib}]} { 10 proc vfs::zip {flag value args} { 11 switch -glob -- "$flag $value" { 12 {-mode d*} { set mode decompress } 13 {-mode c*} { set mode compress } 14 default { error "usage: zip -mode {compress|decompress} data" } 15 } 16 # kludge to allow "-nowrap 1" as second option, 5-9-2002 17 if {[llength $args] > 2 && [lrange $args 0 1] eq "-nowrap 1"} { 18 if {$mode eq "compress"} { 19 set mode deflate 20 } else { 21 set mode inflate 22 } 23 } 24 return [zlib $mode [lindex $args end]] 25 } 26 27 proc vfs::crc {data} { 28 return [zlib crc32 $data] 29 } 30} 31 32# Use 8.6 reflected channels or the rechan package in earlier versions to 33# provide a memory channel implementation. 34# 35if {[info command ::chan] ne {}} { 36 37 # As the core zlib channel stacking make non-seekable channels we cannot 38 # implement vfs::zstream and this feature is disabled in tclkit boot.tcl 39 # when the command is not present (it is only used by mk4vfs) 40 # 41 #proc vfs::zstream {mode ifd clen ilen} { 42 # return -code error "vfs::zstream is unsupported with core zlib" 43 #} 44 proc vfs::memchan {{filename {}}} { 45 return [chan create {read write} \ 46 [list [namespace origin _memchan_handler] $filename]] 47 } 48 proc vfs::_memchan_handler {filename cmd chan args} { 49 upvar #0 ::vfs::_memchan(buf,$chan) buf 50 upvar #0 ::vfs::_memchan(pos,$chan) pos 51 upvar #0 ::vfs::_memchan(name,$chan) name 52 upvar #0 ::vfs::_memchan(timer) timer 53 switch -exact -- $cmd { 54 initialize { 55 foreach {mode} $args break 56 set buf "" 57 set pos 0 58 set watch {} 59 set name $filename 60 if {![info exists timer]} { set timer "" } 61 return {initialize finalize watch read write seek cget cgetall} 62 } 63 finalize { 64 unset buf pos name 65 } 66 seek { 67 foreach {offset base} $args break 68 switch -exact -- $base { 69 current { incr offset $pos } 70 end { incr offset [string length $buf] } 71 } 72 if {$offset < 0} { 73 return -code error "error during seek on \"$chan\":\ 74 invalid argument" 75 } elseif {$offset > [string length $buf]} { 76 set extend [expr {$offset - [string length $buf]}] 77 append buf [binary format @$extend] 78 } 79 return [set pos $offset] 80 } 81 read { 82 foreach {count} $args break 83 set r [string range $buf $pos [expr {$pos + $count - 1}]] 84 incr pos [string length $r] 85 return $r 86 } 87 write { 88 foreach {data} $args break 89 set count [string length $data] 90 if { $pos >= [string length $buf] } { 91 append buf $data 92 } else { 93 set last [expr { $pos + $count - 1 }] 94 set buf [string replace $buf $pos $last $data] 95 } 96 incr pos $count 97 return $count 98 } 99 cget { 100 foreach {option} $args break 101 switch -exact -- $option { 102 -length { return [string length $buf] } 103 -allocated { return [string length $buf] } 104 default { 105 return -code error "bad option \"$option\":\ 106 should be one of -blocking, -buffering,\ 107 -buffersize, -encoding, -eofchar, -translation,\ 108 -length or -allocated" 109 } 110 } 111 } 112 cgetall { 113 return [list -length [string length $buf] \ 114 -allocated [string length $buf]] 115 } 116 watch { 117 foreach {eventspec} $args break 118 after cancel $timer 119 foreach event {read write} { 120 upvar #0 ::vfs::_memchan(watch,$event) watch 121 if {![info exists watch]} { set watch {} } 122 set ndx [lsearch -exact $watch $chan] 123 if {$event in $eventspec} { 124 if {$ndx == -1} { lappend watch $chan } 125 } else { 126 if {$ndx != -1} { 127 set watch [lreplace $watch $ndx $ndx] 128 } 129 } 130 } 131 set timer [after 10 [list ::vfs::_memchan_timer]] 132 } 133 } 134 } 135 # memchan channels are always writable and always readable 136 proc ::vfs::_memchan_timer {} { 137 set continue 0 138 foreach event {read write} { 139 upvar #0 ::vfs::_memchan(watch,$event) watch 140 incr continue [llength $watch] 141 foreach chan $watch { chan postevent $chan $event } 142 } 143 if {$continue > 0} { 144 set ::vfs::_memchan(timer) [after 10 [info level 0]] 145 } 146 } 147 148} elseif {[info command rechan] ne "" || ![catch {load "" rechan}]} { 149 150 proc vfs::memchan_handler {cmd fd args} { 151 upvar 1 ::vfs::_memchan_buf($fd) buf 152 upvar 1 ::vfs::_memchan_pos($fd) pos 153 upvar 1 ::vfs::_memchan_nam($fd) nam 154 set arg1 [lindex $args 0] 155 156 switch -- $cmd { 157 seek { 158 switch [lindex $args 1] { 159 1 - current { incr arg1 $pos } 160 2 - end { incr arg1 [string length $buf]} 161 } 162 return [set pos $arg1] 163 } 164 read { 165 set r [string range $buf $pos [expr { $pos + $arg1 - 1 }]] 166 incr pos [string length $r] 167 return $r 168 } 169 write { 170 set n [string length $arg1] 171 if { $pos >= [string length $buf] } { 172 append buf $arg1 173 } else { # the following doesn't work yet :( 174 set last [expr { $pos + $n - 1 }] 175 set buf [string replace $buf $pos $last $arg1] 176 error "vfs memchan: sorry no inline write yet" 177 } 178 incr pos $n 179 return $n 180 } 181 close { 182 unset buf pos nam 183 } 184 default { error "bad cmd in memchan_handler: $cmd" } 185 } 186 } 187 188 proc vfs::memchan {{filename {}}} { 189 set fd [rechan ::vfs::memchan_handler 6] 190 set ::vfs::_memchan_buf($fd) "" 191 set ::vfs::_memchan_pos($fd) 0 192 set ::vfs::_memchan_nam($fd) $filename 193 return $fd 194 } 195 196 proc vfs::zstream_handler {zcmd ifd clen ilen imode cmd fd {a1 ""} {a2 ""}} { 197 #puts stderr "z $zcmd $ifd $ilen $cmd $fd $a1 $a2" 198 upvar ::vfs::_zstream_pos($fd) pos 199 200 switch -- $cmd { 201 seek { 202 switch $a2 { 203 1 - current { incr a1 $pos } 204 2 - end { incr a1 $ilen } 205 } 206 # to seek back, rewind, i.e. start from scratch 207 if {$a1 < $pos} { 208 rename $zcmd "" 209 zlib $imode $zcmd 210 seek $ifd 0 211 set pos 0 212 } 213 # consume data while not yet at seek position 214 while {$pos < $a1} { 215 set n [expr {$a1 - $pos}] 216 if {$n > 4096} { set n 4096 } 217 # 2003-02-09: read did not work (?), spell it out instead 218 #read $fd $n 219 zstream_handler $zcmd $ifd $clen $ilen $imode read $fd $n 220 } 221 return $pos 222 } 223 read { 224 set r "" 225 set n $a1 226 #puts stderr " want $n z $zcmd pos $pos ilen $ilen" 227 if {$n + $pos > $ilen} { set n [expr {$ilen - $pos}] } 228 while {$n > 0} { 229 if {[$zcmd fill] == 0} { 230 set c [expr {$clen - [tell $ifd]}] 231 if {$c > 4096} { set c 4096 } 232 set data [read $ifd $c] 233 #puts "filled $c [string length $data]" 234 $zcmd fill $data 235 } 236 set data [$zcmd drain $n] 237 #puts stderr " read [string length $data]" 238 if {$data eq ""} break 239 append r $data 240 incr pos [string length $data] 241 incr n -[string length $data] 242 } 243 return $r 244 } 245 close { 246 rename $zcmd "" 247 close $ifd 248 unset pos 249 } 250 default { error "bad cmd in zstream_handler: $cmd" } 251 } 252 } 253 254 variable ::vfs::zseq 0 ;# used to generate temp zstream cmd names 255 256 # vfs::zstream -- 257 # 258 # Create a read-only seekable compressed channel using rechan and 259 # the streaming mode of tclkit's zlib extension. 260 # 261 # mode - compress or decompress 262 # ifd - input channel (should be binary) 263 # clen - size of compressed data in bytes 264 # ilen - size of decompressed data in bytes 265 # 266 proc vfs::zstream {mode ifd clen ilen} { 267 set cname _zstream_[incr ::vfs::zseq] 268 zlib s$mode $cname 269 fconfigure $ifd -translation binary 270 set cmd [list ::vfs::zstream_handler $cname $ifd $clen $ilen s$mode] 271 set fd [rechan $cmd 2] 272 set ::vfs::_zstream_pos($fd) 0 273 return $fd 274 } 275} 276 277