1################################################################################ 2# This is the first try to provide access to tar-files via 3# the vfs-mechanism. 4# This file is copied and adapted from zipvfs.tcl 5# (and ftpvfs.tcl). The internal structure for the tar-data is stored 6# analog to zipvfs so that many functions can be the same as in zipvfs. 7# 8# Jan 13 2003: Stefan Vogel (stefan.vogel@avinci.de) 9# (reformatted to tabsize 8 by Vince). 10# 11# TODOs: 12# * add writable access (should be easy with tar-files) 13# * add gzip-support (?) 14# * more testing :-( 15################################################################################ 16 17package require vfs 18package provide vfs::tar 0.91 19 20# Using the vfs, memchan and Trf extensions, we're able 21# to write a Tcl-only tar filesystem. 22 23namespace eval vfs::tar {} 24 25proc vfs::tar::Mount {tarfile local} { 26 set fd [vfs::tar::_open [::file normalize $tarfile]] 27 vfs::filesystem mount $local [list ::vfs::tar::handler $fd] 28 # Register command to unmount 29 vfs::RegisterMount $local [list ::vfs::tar::Unmount $fd] 30 return $fd 31} 32 33proc vfs::tar::Unmount {fd local} { 34 vfs::filesystem unmount $local 35 vfs::tar::_close $fd 36} 37 38proc vfs::tar::handler {tarfd cmd root relative actualpath args} { 39 if {$cmd == "matchindirectory"} { 40 # e.g. called from "glob *" 41 eval [list $cmd $tarfd $relative $actualpath] $args 42 } else { 43 # called for all other commands: access, stat 44 eval [list $cmd $tarfd $relative] $args 45 } 46} 47 48proc vfs::tar::attributes {tarfd} { return [list "state"] } 49proc vfs::tar::state {tarfd args} { 50 vfs::attributeCantConfigure "state" "readonly" $args 51} 52 53# If we implement the commands below, we will have a perfect 54# virtual file system for tar files. 55# Completely copied from zipvfs.tcl 56 57proc vfs::tar::matchindirectory {tarfd path actualpath pattern type} { 58 # This call to vfs::tar::_getdir handles empty patterns properly as asking 59 # for the existence of a single file $path only 60 set res [vfs::tar::_getdir $tarfd $path $pattern] 61 if {![string length $pattern]} { 62 if {![vfs::tar::_exists $tarfd $path]} { return {} } 63 set res [list $actualpath] 64 set actualpath "" 65 } 66 67 set newres [list] 68 foreach p [::vfs::matchCorrectTypes $type $res $actualpath] { 69 lappend newres [file join $actualpath $p] 70 } 71 return $newres 72} 73 74# return the necessary "array" 75proc vfs::tar::stat {tarfd name} { 76 vfs::tar::_stat $tarfd $name sb 77 array get sb 78} 79 80proc vfs::tar::access {tarfd name mode} { 81 if {$mode & 2} { 82 vfs::filesystem posixerror $::vfs::posix(EROFS) 83 } 84 # Readable, Exists and Executable are treated as 'exists' 85 # Could we get more information from the archive? 86 if {[vfs::tar::_exists $tarfd $name]} { 87 return 1 88 } else { 89 error "No such file" 90 } 91} 92 93proc vfs::tar::open {tarfd name mode permissions} { 94 # return a list of two elements: 95 # 1. first element is the Tcl channel name which has been opened 96 # 2. second element (optional) is a command to evaluate when 97 # the channel is closed. 98 99 switch -- $mode { 100 "" - 101 "r" { 102 if {![vfs::tar::_exists $tarfd $name]} { 103 vfs::filesystem posixerror $::vfs::posix(ENOENT) 104 } 105 106 vfs::tar::_stat $tarfd $name sb 107 108 set nfd [vfs::memchan] 109 fconfigure $nfd -translation binary 110 111 # get the starting point from structure 112 seek $tarfd $sb(start) start 113 vfs::tar::_data $tarfd sb data 114 115 puts -nonewline $nfd $data 116 117 fconfigure $nfd -translation auto 118 seek $nfd 0 119 return [list $nfd] 120 } 121 default { 122 vfs::filesystem posixerror $::vfs::posix(EROFS) 123 } 124 } 125} 126 127proc vfs::tar::createdirectory {tarfd name} { 128 vfs::filesystem posixerror $::vfs::posix(EROFS) 129 #error "tar-archives are read-only (not implemented)" 130} 131 132proc vfs::tar::removedirectory {tarfd name recursive} { 133 #::vfs::log "removedirectory $name" 134 vfs::filesystem posixerror $::vfs::posix(EROFS) 135 #error "tar-archives are read-only (not implemented)" 136} 137 138proc vfs::tar::deletefile {tarfd name} { 139 vfs::filesystem posixerror $::vfs::posix(EROFS) 140 #error "tar-archives are read-only (not implemented)" 141} 142 143# don't care about platform-specific attributes 144proc vfs::tar::fileattributes {tarfd name args} { 145 #::vfs::log "fileattributes $args" 146 switch -- [llength $args] { 147 0 { 148 # list strings 149 return [list] 150 } 151 1 { 152 # get value 153 set index [lindex $args 0] 154 return "" 155 } 156 2 { 157 # set value 158 set index [lindex $args 0] 159 set val [lindex $args 1] 160 vfs::filesystem posixerror $::vfs::posix(EROFS) 161 } 162 } 163} 164 165# set the 'mtime' of a file. 166proc vfs::tar::utime {fd path actime mtime} { 167 vfs::filesystem posixerror $::vfs::posix(EROFS) 168} 169 170# 171# tar decoder: 172# 173# Format of tar file: 174# see http://www.gnu.org/manual/tar/html_node/tar_123.html 175# "comments" are put into the the arrays for readability 176# the fields in aPosixHeader are stored inside a 177# 512-byte-block. Not all header-fields are used here. 178# 179# Here are some excerpts from the above resource for information 180# only: 181# 182# name, linkname, magic, uname, and gname are null-terminated strings. 183# All other fileds are zero-filled octal numbers in ASCII. 184# Each numeric field of width w contains 185# w minus 2 digits, a space, and a null, 186# except size, and mtime, which do not contain the trailing null 187 188# mtime field is the modification time of the file at the time it was 189# archived. It is the ASCII representation of the octal value of the 190# last time the file was modified, represented as an integer number 191# of seconds since January 1, 1970, 00:00 Coordinated Universal Time 192 193 194namespace eval vfs::tar { 195 set HEADER_SIZE 500 196 set BLOCK_SIZE 512 197 198 # fields of header with start/end-index in "comments": length of 199 # field in bytes (just for documentation) prefix is the 200 # "datatype": s == null-terminated string o == zero-filled octal 201 # number (numeric but leave it octal e.g mode) n == numeric --> 202 # integer change to decimal) "not used" is marked when the field 203 # is not needed anywhere here 204 array set aPosixHeader { 205 name {s 0 99} # 100 206 mode {o 100 107} # "8 - not used now" 207 uid {n 108 115} # 8 208 gid {n 116 123} # 8 209 size {n 124 135} # 12 210 mtime {n 136 147} # 12 211 chksum {o 148 155} # "8 - not used" 212 typeflag {o 156 156} # 1 213 linkname {s 157 256} # "100 - not used" 214 magic {s 257 262} # "6 - not used" 215 version {o 263 264} # "2 - not used" 216 uname {s 265 296} # "32 - not used" 217 gname {s 297 328} # "32 - not used" 218 devmajor {o 329 336} # "8 - not used" 219 devminor {o 337 344} # "8 - not used" 220 prefix {o 345 499} # "155 - not used" 221 } 222 223 # just for compatibility with posix-header 224 # only DIRTYPE is used 225 array set aTypeFlag { 226 REGTYPE 0 # "regular file" 227 AREGTYPE \000 # "regular file" 228 LNKTYPE 1 # link 229 SYMTYPE 2 # reserved 230 CHRTYPE 3 # "character special" 231 BLKTYPE 4 # "block special" 232 DIRTYPE 5 # directory 233 FIFOTYPE 6 # "FIFO special" 234 CONTTYPE 7 # reserved 235 } 236} 237 238proc vfs::tar::_data {fd arr {varPtr ""}} { 239 upvar 1 $arr sb 240 241 if {$varPtr eq ""} { 242 seek $fd $sb(size) current 243 } else { 244 upvar 1 $varPtr data 245 set data [read $fd $sb(size)] 246 } 247} 248 249proc vfs::tar::TOC {fd arr toc} { 250 variable aPosixHeader 251 variable aTypeFlag 252 variable HEADER_SIZE 253 variable BLOCK_SIZE 254 255 upvar 1 $arr sb 256 upvar 1 $toc _toc 257 258 set pos 0 259 set sb(nitems) 0 260 261 # loop through file in blocks of BLOCK_SIZE 262 while {![eof $fd]} { 263 seek $fd $pos 264 set hdr [read $fd $BLOCK_SIZE] 265 266 # read header-fields from block (see aPosixHeader) 267 foreach key {name typeflag size mtime uid gid} { 268 set type [lindex $aPosixHeader($key) 0] 269 set positions [lrange $aPosixHeader($key) 1 2] 270 switch $type { 271 s { 272 set $key [eval [list string range $hdr] $positions] 273 # cut the trailing Nulls 274 set $key [string range [set $key] 0 [expr [string first "\000" [set $key]]-1]] 275 } 276 o { 277 # leave it as is (octal value) 278 set $key [eval [list string range $hdr] $positions] 279 } 280 n { 281 set $key [eval [list string range $hdr] $positions] 282 # change to integer 283 scan [set $key] "%o" $key 284 # if not set, set default-value "0" 285 # (size == "" is not a very good value) 286 if {![string is integer [set $key]] || [set $key] == ""} { set $key 0 } 287 } 288 default { 289 error "tar::TOC: '$fd' wrong type for header-field: '$type'" 290 } 291 } 292 } 293 294 # only the last three octals are interesting for mode 295 # ignore mode now, should this be added?? 296 # set mode 0[string range $mode end-3 end] 297 298 # get the increment to the next valid block 299 # (ignore file-blocks in between) 300 # if size == 0 the minimum incr is 512 301 set incr [expr {int(ceil($size/double($BLOCK_SIZE)))*$BLOCK_SIZE+$BLOCK_SIZE}] 302 303 set startPosition [expr {$pos+$BLOCK_SIZE}] 304 # make it relative to this working-directory, remove the 305 # leading "relative"-paths 306 regexp -- {^(?:\.\.?/)*/?(.*)} $name -> name 307 308 if {$name != ""} { 309 incr sb(nitems) 310 set sb($name,start) [expr {$pos+$BLOCK_SIZE}] 311 set sb($name,size) $size 312 set type "file" 313 # the mode should be 0777?? or must be changed to decimal? 314 if {$typeflag == $aTypeFlag(DIRTYPE)} { 315 # directory! append this without / 316 # leave mode: 0777 317 # (else we might not be able to walk through archive) 318 set type "directory" 319 lappend _toc([string trimright $name "/"]) \ 320 name [string trimright $name "/"] \ 321 type $type mtime $mtime size $size mode 0777 \ 322 ino -1 start $startPosition \ 323 depth [llength [file split $name]] \ 324 uid $uid gid $gid 325 } 326 lappend _toc($name) \ 327 name $name \ 328 type $type mtime $mtime size $size mode 0777 \ 329 ino -1 start $startPosition depth [llength [file split $name]] \ 330 uid $uid gid $gid 331 } 332 incr pos $incr 333 } 334 return 335} 336 337proc vfs::tar::_open {path} { 338 set fd [::open $path] 339 340 if {[catch { 341 upvar #0 vfs::tar::$fd.toc toc 342 fconfigure $fd -translation binary ;#-buffering none 343 vfs::tar::TOC $fd sb toc 344 } err]} { 345 close $fd 346 return -code error $err 347 } 348 349 return $fd 350} 351 352proc vfs::tar::_exists {fd path} { 353 #::vfs::log "$fd $path" 354 if {$path == ""} { 355 return 1 356 } else { 357 upvar #0 vfs::tar::$fd.toc toc 358 return [expr {[info exists toc($path)] || [info exists toc([string trimright $path "/"]/)]}] 359 } 360} 361 362proc vfs::tar::_stat {fd path arr} { 363 upvar #0 vfs::tar::$fd.toc toc 364 upvar 1 $arr sb 365 366 if { $path == "" || $path == "." } { 367 array set sb { 368 type directory mtime 0 size 0 mode 0777 369 ino -1 depth 0 name "" 370 } 371 } elseif {![info exists toc($path)] } { 372 return -code error "could not read \"$path\": no such file or directory" 373 } else { 374 array set sb $toc($path) 375 } 376 377 # set missing attributes 378 set sb(dev) -1 379 set sb(nlink) 1 380 set sb(atime) $sb(mtime) 381 set sb(ctime) $sb(mtime) 382 383 return "" 384} 385 386# Treats empty pattern as asking for a particular file only. 387# Directly copied from zipvfs. 388proc vfs::tar::_getdir {fd path {pat *}} { 389 upvar #0 vfs::tar::$fd.toc toc 390 391 if { $path == "." || $path == "" } { 392 set path $pat 393 } else { 394 set path [string tolower $path] 395 if {$pat != ""} { 396 append path /$pat 397 } 398 } 399 set depth [llength [file split $path]] 400 401 if {$depth} { 402 set ret {} 403 foreach key [array names toc $path] { 404 if {[string index $key end] eq "/"} { 405 # Directories are listed twice: both with and without 406 # the trailing '/', so we ignore the one with 407 continue 408 } 409 array set sb $toc($key) 410 411 if { $sb(depth) == $depth } { 412 if {[info exists toc(${key}/)]} { 413 array set sb $toc(${key}/) 414 } 415 # remove sb(name) (because == $key) 416 lappend ret [file tail $key] 417 } 418 unset sb 419 } 420 return $ret 421 } else { 422 # just the 'root' of the zip archive. This obviously exists and 423 # is a directory. 424 return [list {}] 425 } 426} 427 428proc vfs::tar::_close {fd} { 429 variable $fd.toc 430 unset -nocomplain $fd.toc 431 ::close $fd 432} 433