1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
# Remnants of what used to be VFS init, this is TclKit-specific
package require Tcl 8.4; # vfs is all new for 8.4
package provide vfslib 1.3
namespace eval ::vfs {
variable zseq 0 ;# used to generate temp zstream cmd names
# for backwards compatibility
proc normalize {path} { ::file normalize $path }
# use zlib to define zip and crc if available
if {[info command zlib] != "" || ![catch {load "" zlib}]} {
proc zip {flag value args} {
switch -glob -- "$flag $value" {
{-mode d*} { set mode decompress }
{-mode c*} { set mode compress }
default { error "usage: zip -mode {compress|decompress} data" }
}
# kludge to allow "-nowrap 1" as second option, 5-9-2002
if {[llength $args] > 2 && [lrange $args 0 1] == "-nowrap 1"} {
if {$mode == "compress"} {
set mode deflate
} else {
set mode inflate
}
}
return [zlib $mode [lindex $args end]]
}
proc crc {data} {
return [zlib crc32 $data]
}
}
# use rechan to define memchan and zstream if available
if {[info command rechan] != "" || ![catch {load "" rechan}]} {
proc memchan_handler {cmd fd args} {
upvar ::vfs::_memchan_buf($fd) buf
upvar ::vfs::_memchan_pos($fd) pos
set arg1 [lindex $args 0]
switch -- $cmd {
seek {
switch [lindex $args 1] {
1 - current { incr arg1 $pos }
2 - end { incr arg1 [string length $buf]}
}
return [set pos $arg1]
}
read {
set r [string range $buf $pos [expr { $pos + $arg1 - 1 }]]
incr pos [string length $r]
return $r
}
write {
set n [string length $arg1]
if { $pos >= [string length $buf] } {
append buf $arg1
} else { # the following doesn't work yet :(
set last [expr { $pos + $n - 1 }]
set buf [string replace $buf $pos $last $arg1]
error "vfs memchan: sorry no inline write yet"
}
incr pos $n
return $n
}
close {
unset buf pos
}
default { error "bad cmd in memchan_handler: $cmd" }
}
}
proc memchan {} {
set fd [rechan ::vfs::memchan_handler 6]
set ::vfs::_memchan_buf($fd) ""
set ::vfs::_memchan_pos($fd) 0
return $fd
}
proc zstream_handler {zcmd ifd clen ilen imode cmd fd {a1 ""} {a2 ""}} {
#puts stderr "z $zcmd $ifd $ilen $cmd $fd $a1 $a2"
upvar ::vfs::_zstream_pos($fd) pos
switch -- $cmd {
seek {
switch $a2 {
1 - current { incr a1 $pos }
2 - end { incr a1 $ilen }
}
# to seek back, rewind, i.e. start from scratch
if {$a1 < $pos} {
rename $zcmd ""
zlib $imode $zcmd
seek $ifd 0
set pos 0
}
# consume data while not yet at seek position
while {$pos < $a1} {
set n [expr {$a1 - $pos}]
if {$n > 4096} { set n 4096 }
# 2003-02-09: read did not work (?), spell it out instead
#read $fd $n
zstream_handler $zcmd $ifd $clen $ilen $imode read $fd $n
}
return $pos
}
read {
set r ""
set n $a1
#puts stderr " want $n z $zcmd pos $pos ilen $ilen"
if {$n + $pos > $ilen} { set n [expr {$ilen - $pos}] }
while {$n > 0} {
if {[$zcmd fill] == 0} {
set c [expr {$clen - [tell $ifd]}]
if {$c > 4096} { set c 4096 }
set data [read $ifd $c]
#puts "filled $c [string length $data]"
$zcmd fill $data
}
set data [$zcmd drain $n]
#puts stderr " read [string length $data]"
if {$data eq ""} break
append r $data
incr pos [string length $data]
incr n -[string length $data]
}
return $r
}
close {
rename $zcmd ""
close $ifd
unset pos
}
default { error "bad cmd in zstream_handler: $cmd" }
}
}
proc zstream {mode ifd clen ilen} {
set cname _zstream_[incr ::vfs::zseq]
zlib s$mode $cname
set cmd [list ::vfs::zstream_handler $cname $ifd $clen $ilen s$mode]
set fd [rechan $cmd 2]
set ::vfs::_zstream_pos($fd) 0
return $fd
}
}
}
|
