/usr/share/tcltk/vfs1.3/vfslib.tcl is in tcl-vfs 1.3-20080503-4.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | # 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.1
namespace eval ::vfs {
variable zseq 0 ;# used to generate temp zstream cmd names
}
# for backwards compatibility
proc vfs::normalize {path} { ::file normalize $path }
# use zlib to define zip and crc if available
if {[llength [info command zlib]] || ![catch {load "" zlib}]} {
proc vfs::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] eq "-nowrap 1"} {
if {$mode eq "compress"} {
set mode deflate
} else {
set mode inflate
}
}
return [zlib $mode [lindex $args end]]
}
proc vfs::crc {data} {
return [zlib crc32 $data]
}
}
# use rechan to define memchan and zstream if available
if {[info command rechan] != "" || ![catch {load "" rechan}]} {
proc vfs::memchan_handler {cmd fd args} {
upvar 1 ::vfs::_memchan_buf($fd) buf
upvar 1 ::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 vfs::memchan {} {
set fd [rechan ::vfs::memchan_handler 6]
set ::vfs::_memchan_buf($fd) ""
set ::vfs::_memchan_pos($fd) 0
return $fd
}
proc vfs::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 vfs::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
}
}
|