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