--- /dev/null
+################################################################################
+# This is the first try to provide access to tar-files via
+# the vfs-mechanism.
+# This file is copied and adapted from zipvfs.tcl
+# (and ftpvfs.tcl). The internal structure for the tar-data is stored
+# analog to zipvfs so that many functions can be the same as in zipvfs.
+#
+# Jan 13 2003: Stefan Vogel (stefan.vogel@avinci.de)
+# (reformatted to tabsize 8 by Vince).
+#
+# TODOs:
+# * add writable access (should be easy with tar-files)
+# * add gzip-support (?)
+# * more testing :-(
+################################################################################
+
+package require vfs
+package provide tarvfs 0.1
+
+# Using the vfs, memchan and Trf extensions, we're able
+# to write a Tcl-only tar filesystem.
+
+namespace eval vfs::tar {}
+
+proc vfs::tar::Mount {tarfile local} {
+ set fd [::tar::open [::file normalize $tarfile]]
+ vfs::filesystem mount $local [list ::vfs::tar::handler $fd]
+ # Register command to unmount
+ vfs::RegisterMount $local [list ::vfs::tar::Unmount $fd]
+ return $fd
+}
+
+proc vfs::tar::Unmount {fd local} {
+ vfs::filesystem unmount $local
+ ::tar::_close $fd
+}
+
+proc vfs::tar::handler {tarfd cmd root relative actualpath args} {
+ if {$cmd == "matchindirectory"} {
+ # e.g. called from "glob *"
+ eval [list $cmd $tarfd $relative $actualpath] $args
+ } else {
+ # called for all other commands: access, stat
+ eval [list $cmd $tarfd $relative] $args
+ }
+}
+
+# If we implement the commands below, we will have a perfect
+# virtual file system for tar files.
+# Completely copied from zipvfs.tcl
+
+proc vfs::tar::matchindirectory {tarfd path actualpath pattern type} {
+ # This call to tar::getdir handles empty patterns properly as asking
+ # for the existence of a single file $path only
+ set res [::tar::getdir $tarfd $path $pattern]
+ if {![string length $pattern]} {
+ set res [list $actualpath]
+ set actualpath ""
+ }
+
+ set newres [list]
+ foreach p [::vfs::matchCorrectTypes $type $res $actualpath] {
+ lappend newres "$actualpath$p"
+ }
+ return $newres
+}
+
+# return the necessary "array"
+proc vfs::tar::stat {tarfd name} {
+ ::tar::stat $tarfd $name sb
+ array get sb
+}
+
+proc vfs::tar::access {tarfd name mode} {
+ if {$mode & 2} {
+ error "read-only"
+ }
+ # Readable, Exists and Executable are treated as 'exists'
+ # Could we get more information from the archive?
+ if {[::tar::exists $tarfd $name]} {
+ return 1
+ } else {
+ error "No such file"
+ }
+
+}
+
+proc vfs::tar::open {tarfd name mode permissions} {
+ # return a list of two elements:
+ # 1. first element is the Tcl channel name which has been opened
+ # 2. second element (optional) is a command to evaluate when
+ # the channel is closed.
+
+ switch -- $mode {
+ "" -
+ "r" {
+ if {![::tar::exists $tarfd $name]} {
+ return -code error $::vfs::posix(ENOENT)
+ }
+
+ ::tar::stat $tarfd $name sb
+
+ set nfd [vfs::memchan]
+ fconfigure $nfd -translation binary
+
+ # get the starting point from structure
+ seek $tarfd $sb(start) start
+ tar::Data $tarfd sb data
+
+ puts -nonewline $nfd $data
+
+ fconfigure $nfd -translation auto
+ seek $nfd 0
+ return [list $nfd]
+ }
+ default {
+ return -code error "illegal access mode \"$mode\""
+ }
+ }
+}
+
+proc vfs::tar::createdirectory {tarfd name} {
+ error "tar-archives are read-only (not implemented)"
+}
+
+proc vfs::tar::removedirectory {tarfd name} {
+ #::vfs::log "removedirectory $name"
+ error "tar-archives are read-only (not implemented)"
+}
+
+proc vfs::tar::deletefile {tarfd name} {
+ error "tar-archives are read-only (not implemented)"
+}
+
+# don't care about platform-specific attributes
+proc vfs::tar::fileattributes {tarfd name args} {
+ #::vfs::log "fileattributes $args"
+ switch -- [llength $args] {
+ 0 {
+ # list strings
+ return [list]
+ }
+ 1 {
+ # get value
+ set index [lindex $args 0]
+ return ""
+ }
+ 2 {
+ # set value
+ set index [lindex $args 0]
+ set val [lindex $args 1]
+ error "tar-archives are read-only"
+ }
+ }
+}
+
+# is this needed??
+proc vfs::tar::utime {fd path actime mtime} {
+ error ""
+}
+
+#
+# tar decoder:
+#
+# Format of tar file:
+# see http://www.gnu.org/manual/tar/html_node/tar_123.html
+# "comments" are put into the the arrays for readability
+# the fields in aPosixHeader are stored inside a
+# 512-byte-block. Not all header-fields are used here.
+#
+# Here are some excerpts from the above resource for information
+# only:
+#
+# name, linkname, magic, uname, and gname are null-terminated strings.
+# All other fileds are zero-filled octal numbers in ASCII.
+# Each numeric field of width w contains
+# w minus 2 digits, a space, and a null,
+# except size, and mtime, which do not contain the trailing null
+
+# mtime field is the modification time of the file at the time it was
+# archived. It is the ASCII representation of the octal value of the
+# last time the file was modified, represented as an integer number
+# of seconds since January 1, 1970, 00:00 Coordinated Universal Time
+
+
+namespace eval tar {
+
+ set HEADER_SIZE 500 set BLOCK_SIZE 512
+
+ # fields of header with start/end-index in "comments": length of
+ # field in bytes (just for documentation) prefix is the
+ # "datatype": s == null-terminated string o == zero-filled octal
+ # number (numeric but leave it octal e.g mode) n == numeric -->
+ # integer change to decimal) "not used" is marked when the field
+ # is not needed anywhere here
+ array set aPosixHeader {
+ name {s 0 99} # 100
+ mode {o 100 107} # "8 - not used now"
+ uid {n 108 115} # 8
+ gid {n 116 123} # 8
+ size {n 124 135} # 12
+ mtime {n 136 147} # 12
+ chksum {o 148 155} # "8 - not used"
+ typeflag {o 156 156} # 1
+ linkname {s 157 256} # "100 - not used"
+ magic {s 257 262} # "6 - not used"
+ version {o 263 264} # "2 - not used"
+ uname {s 265 296} # "32 - not used"
+ gname {s 297 328} # "32 - not used"
+ devmajor {o 329 336} # "8 - not used"
+ devminor {o 337 344} # "8 - not used"
+ prefix {o 345 499} # "155 - not used"
+ }
+
+ # just for compatibility with posix-header
+ # only DIRTYPE is used
+ array set aTypeFlag {
+ REGTYPE 0 # "regular file"
+ AREGTYPE \000 # "regular file"
+ LNKTYPE 1 # link
+ SYMTYPE 2 # reserved
+ CHRTYPE 3 # "character special"
+ BLKTYPE 4 # "block special"
+ DIRTYPE 5 # directory
+ FIFOTYPE 6 # "FIFO special"
+ CONTTYPE 7 # reserved
+ }
+}
+
+proc tar::Data {fd arr {varPtr ""}} {
+ upvar 1 $arr sb
+
+ if { $varPtr != "" } {
+ upvar 1 $varPtr data
+ }
+
+ if { $varPtr == "" } {
+ seek $fd $sb(size) current
+ } else {
+ set data [read $fd $sb(size)]
+ }
+
+ if { $varPtr == "" } {
+ return ""
+ }
+}
+
+proc tar::TOC {fd arr toc} {
+ variable aPosixHeader
+ variable aTypeFlag
+ variable HEADER_SIZE
+ variable BLOCK_SIZE
+
+ upvar 1 $arr sb
+ upvar 1 $toc _toc
+
+ set pos 0
+ set sb(nitems) 0
+
+ # loop through file in blocks of BLOCK_SIZE
+ while {![eof $fd]} {
+ seek $fd $pos
+ set hdr [read $fd $BLOCK_SIZE]
+
+ # read header-fields from block (see aPosixHeader)
+ foreach key {name typeflag size mtime uid gid} {
+ set type [lindex $aPosixHeader($key) 0]
+ set positions [lrange $aPosixHeader($key) 1 2]
+ switch $type {
+ s {
+ set $key [eval string range [list $hdr] $positions]
+ # cut the trailing Nulls
+ set $key [string range [set $key] 0 [expr [string first "\000" [set $key]]-1]]
+ }
+ o {
+ # leave it as is (octal value)
+ set $key [eval string range [list $hdr] $positions]
+ }
+ n {
+ set $key [eval string range [list $hdr] $positions]
+ # change to integer
+ scan [set $key] "%o" $key
+ # if not set, set default-value "0"
+ # (size == "" is not a very good value)
+ if {![string is integer [set $key]] || [set $key] == ""} { set $key 0 }
+ }
+ default {
+ error "tar::TOC: '$fd' wrong type for header-field: '$type'"
+ }
+ }
+ }
+
+ # only the last three octals are interesting for mode
+ # ignore mode now, should this be added??
+ # set mode 0[string range $mode end-3 end]
+
+ # get the increment to the next valid block
+ # (ignore file-blocks in between)
+ # if size == 0 the minimum incr is 512
+ set incr [expr int(ceil($size/double($BLOCK_SIZE)))*$BLOCK_SIZE+$BLOCK_SIZE]
+
+ set startPosition [expr $pos+$BLOCK_SIZE]
+ if {$name != ""} {
+ incr sb(nitems)
+ set sb($name,start) [expr $pos+$BLOCK_SIZE]
+ set sb($name,size) $size
+ set type "file"
+ # the mode should be 0777?? or must be changed to decimal?
+ if {$typeflag == $aTypeFlag(DIRTYPE)} {
+ # directory! append this without /
+ # leave mode: 0777
+ # (else we might not be able to walk through archive)
+ set type "directory"
+ lappend _toc([string trimright $name "/"]) \
+ name [string trimright $name "/"] \
+ type $type mtime $mtime size $size mode 0777 \
+ ino -1 start $startPosition \
+ depth [llength [file split $name]] \
+ uid $uid gid $gid
+ }
+ lappend _toc($name) \
+ name $name \
+ type $type mtime $mtime size $size mode 0777 \
+ ino -1 start $startPosition depth [llength [file split $name]] \
+ uid $uid gid $gid
+ }
+ incr pos $incr
+ }
+ return
+}
+
+proc tar::open {path} {
+ set fd [::open $path]
+ upvar #0 tar::$fd.toc toc
+
+ fconfigure $fd -translation binary ;#-buffering none
+
+ tar::TOC $fd sb toc
+ return $fd
+}
+
+proc tar::exists {fd path} {
+ #::vfs::log "$fd $path"
+ if {$path == ""} {
+ return 1
+ } else {
+ upvar #0 tar::$fd.toc toc
+ return [expr [info exists toc($path)] || [info exists toc([string trimright $path "/"]/)]]
+ }
+}
+
+proc tar::stat {fd path arr} {
+ upvar #0 tar::$fd.toc toc
+ upvar 1 $arr sb
+
+ if { $path == "" || $path == "." } {
+ array set sb {
+ type directory mtime 0 size 0 mode 0777
+ ino -1 depth 0 name ""
+ }
+ } elseif {![info exists toc($path)] } {
+ return -code error "could not read \"$path\": no such file or directory"
+ } else {
+ array set sb $toc($path)
+ }
+
+ # set missing attributes
+ set sb(dev) -1
+ set sb(nlink) 1
+ set sb(atime) $sb(mtime)
+ set sb(ctime) $sb(mtime)
+
+ return ""
+}
+
+# Treats empty pattern as asking for a particular file only.
+# Directly copied from zipvfs.
+proc tar::getdir {fd path {pat *}} {
+ upvar #0 tar::$fd.toc toc
+
+ if { $path == "." || $path == "" } {
+ set path $pat
+ } else {
+ set path [string tolower $path]
+ if {$pat != ""} {
+ append path /$pat
+ }
+ }
+ set depth [llength [file split $path]]
+
+ if {$depth} {
+ set ret {}
+ foreach key [array names toc $path] {
+ if {[string index $key end] == "/"} {
+ # Directories are listed twice: both with and without
+ # the trailing '/', so we ignore the one with
+ continue
+ }
+ array set sb $toc($key)
+
+ if { $sb(depth) == $depth } {
+ if {[info exists toc(${key}/)]} {
+ array set sb $toc(${key}/)
+ }
+ # remove sb(name) (because == $key)
+ lappend ret [file tail $key]
+ }
+ unset sb
+ }
+ return $ret
+ } else {
+ # just the 'root' of the zip archive. This obviously exists and
+ # is a directory.
+ return [list {}]
+ }
+}
+
+proc tar::_close {fd} {
+ variable $fd.toc
+ unset $fd.toc
+}
projects / tclvfs / commitdiff