From: Vince Darley <vincentdarley@sourceforge.net>
Date: Tue, 14 Jan 2003 09:30:16 +0000 (+0000)
Subject: new tar vfs from Stefan
X-Git-Tag: vfs-1-2~19
X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=a1a321041f3cc0054b0fd63d2c6bdee5b4913aa3;p=tclvfs

new tar vfs from Stefan
---

diff --git a/ChangeLog b/ChangeLog
index a5e2fcd..ca7ee5a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2003-01-14  Vince Darley <vincentdarley@sourceforge.net>
+	* library/tarvfs.tcl: new 'tar' filesystem courtesy of Stefan
+	Vogel -- many thanks!  The tar vfs is currently read-only and
+	doesn't support .tgz.
+	
 2003-01-06  Vince Darley <vincentdarley@sourceforge.net>
 	* library/ftpvfs.tcl: allow 'file mtime' to set the modified
 	time of a file, if the ftp package supports it.
diff --git a/library/tarvfs.tcl b/library/tarvfs.tcl
new file mode 100644
index 0000000..d28e10d
--- /dev/null
+++ b/library/tarvfs.tcl
@@ -0,0 +1,421 @@
+################################################################################
+# 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
+}