Attachment "tar.patch" to
ticket [2840147fff]
added by
lars_h
2009-08-19 16:03:45.
Index: tar.man
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/tar/tar.man,v
retrieving revision 1.18
diff -U3 -r1.18 tar.man
--- tar.man 29 Jan 2009 06:16:20 -0000 1.18
+++ tar.man 19 Aug 2009 08:23:38 -0000
@@ -1,10 +1,10 @@
[comment {-*- tcl -*- doctools manpage}]
-[manpage_begin tar n 0.4]
+[manpage_begin tar n 0.6]
[moddesc {Tar file handling}]
[titledesc {Tar file creation, extraction & manipulation}]
[category {File formats}]
[require Tcl 8.4]
-[require tar [opt 0.4]]
+[require tar [opt 0.6]]
[description]
@@ -103,6 +103,16 @@
Normally [cmd add] will store links as an actual link pointing at a file that may
or may not exist in the archive. Specifying this option will cause the actual file point to
by the link to be stored instead.
+[opt_def -prefix string]
+Normally [cmd add] will store files under exactly the name specified as
+argument. Specifying a [opt -prefix] causes the [arg string] to be
+prepended to every name.
+[opt_def -quick]
+The only sure way to find the position in the [arg tarball] where new
+files can be added is to read it from start, but if [arg tarball] was
+written with a "blocksize" of 1 (as this package does) then one can
+alternatively find this position by seeking from the end. The
+[opt -quick] option tells [cmd add] to do the latter.
[list_end]
[para]
Index: tar.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/tar/tar.tcl,v
retrieving revision 1.14
diff -U3 -r1.14 tar.tcl
--- tar.tcl 13 May 2009 21:27:29 -0000 1.14
+++ tar.tcl 19 Aug 2009 08:23:38 -0000
@@ -9,7 +9,7 @@
#
# RCS: @(#) $Id: tar.tcl,v 1.14 2009/05/13 21:27:29 afaupell Exp $
-package provide tar 0.5
+package provide tar 0.6
namespace eval ::tar {}
@@ -206,34 +206,90 @@
return $ret
}
-proc ::tar::createHeader {name followlinks} {
- foreach x {linkname uname gname prefix devmajor devminor} {set $x ""}
-
+##
+ # ::tar::statFile
+ #
+ # Returns stat info about a filesystem object, in the form of an info
+ # dictionary like that returned by ::tar::readHeader.
+ #
+ # The mode, uid, gid, mtime, and type entries are always present.
+ # The size and linkname entries are present if relevant for this type
+ # of object. The uname and gname entries are present if the OS supports
+ # them. No devmajor or devminor entry is present.
+ ##
+
+proc ::tar::statFile {name followlinks} {
if {$followlinks} {
file stat $name stat
} else {
file lstat $name stat
}
- set type [string map {file 0 directory 5 characterSpecial 3 blockSpecial 4 fifo 6 link 2 socket A} $stat(type)]
- set gid [format %o $stat(gid)]
- set uid [format %o $stat(uid)]
- set mtime [format %o $stat(mtime)]
+ set ret {}
if {$::tcl_platform(platform) == "unix"} {
- set uname [file attributes $name -owner]
- set gname [file attributes $name -group]
- set mode 1[file attributes $name -permissions]
- if {$stat(type) == "link"} {set linkname [file link $name]}
+ lappend ret mode 1[file attributes $name -permissions]
+ lappend ret uname [file attributes $name -owner]
+ lappend ret gname [file attributes $name -group]
+ if {$stat(type) == "link"} {
+ lappend ret linkname [file link $name]
+ }
} else {
- set mode 100644
- if {$stat(type) == "directory"} {set mode 100755}
+ lappend ret mode [lindex {100644 100755} [expr {$stat(type) == "directory"}]]
}
- set size 0
- if {$stat(type) == "file"} {
- set size [format %o $stat(size)]
- }
+ lappend ret uid $stat(uid) gid $stat(gid) mtime $stat(mtime) \
+ type $stat(type)
+
+ if {$stat(type) == "file"} {lappend ret size $stat(size)}
+
+ return $ret
+}
+
+##
+ # ::tar::formatHeader
+ #
+ # Opposite operation to ::tar::readHeader; takes a file name and info
+ # dictionary as arguments, returns a corresponding (POSIX-tar) header.
+ #
+ # The following dictionary entries must be present:
+ # mode
+ # type
+ #
+ # The following dictionary entries are used if present, otherwise
+ # the indicated default is used:
+ # uid 0
+ # gid 0
+ # size 0
+ # mtime [clock seconds]
+ # linkname {}
+ # uname {}
+ # gname {}
+ #
+ # All other dictionary entries, including devmajor and devminor, are
+ # presently ignored.
+ ##
+
+proc ::tar::formatHeader {name info} {
+ array set A {
+ linkname ""
+ uname ""
+ gname ""
+ size 0
+ gid 0
+ uid 0
+ }
+ set A(mtime) [clock seconds]
+ array set A $info
+ array set A {devmajor "" devminor ""}
+
+ set type [string map {file 0 directory 5 characterSpecial 3 \
+ blockSpecial 4 fifo 6 link 2 socket A} $A(type)]
+
+ set osize [format %o $A(size)]
+ set ogid [format %o $A(gid)]
+ set ouid [format %o $A(uid)]
+ set omtime [format %o $A(mtime)]
set name [string trimleft $name /]
if {[string length $name] > 255} {
@@ -241,11 +297,15 @@
} elseif {[string length $name] > 100} {
set prefix [string range $name 0 end-100]
set name [string range $name end-99 end]
+ } else {
+ set prefix ""
}
set header [binary format a100A8A8A8A12A12A8a1a100A6a2a32a32a8a8a155a12 \
- $name $mode\x00 $uid\x00 $gid\x00 $size\x00 $mtime\x00 {} $type \
- $linkname ustar\x00 00 $uname $gname $devmajor $devminor $prefix {}]
+ $name $A(mode)\x00 $ouid\x00 $ogid\x00\
+ $osize\x00 $omtime\x00 {} $type \
+ $A(linkname) ustar\x00 00 $A(uname) $A(gname)\
+ $A(devmajor) $A(devminor) $prefix {}]
binary scan $header c* tmp
set cksum 0
@@ -254,6 +314,7 @@
return [string replace $header 148 155 [binary format A8 [format %o $cksum]\x00]]
}
+
proc ::tar::recurseDirs {files followlinks} {
foreach x $files {
if {[file isdirectory $x] && ([file type $x] != "link" || $followlinks)} {
@@ -267,8 +328,8 @@
return $files
}
-proc ::tar::writefile {in out followlinks} {
- puts -nonewline $out [createHeader $in $followlinks]
+proc ::tar::writefile {in out followlinks name} {
+ puts -nonewline $out [formatHeader $name [statFile $in $followlinks]]
set size 0
if {[file type $in] == "file" || ($followlinks && [file type $in] == "link")} {
set in [::open $in]
@@ -286,7 +347,7 @@
set fh [::open $tar w+]
fconfigure $fh -encoding binary -translation lf -eofchar {}
foreach x [recurseDirs $files $dereference] {
- writefile $x $fh $dereference
+ writefile $x $fh $dereference $x
}
puts -nonewline $fh [string repeat \x00 1024]
@@ -296,14 +357,27 @@
proc ::tar::add {tar files args} {
set dereference 0
- parseOpts {dereference 0} $args
+ set prefix ""
+ set quick 0
+ parseOpts {dereference 0 prefix 1 quick 0} $args
set fh [::open $tar r+]
fconfigure $fh -encoding binary -translation lf -eofchar {}
- seek $fh -1024 end
+
+ if {$quick} then {
+ seek $fh -1024 end
+ } else {
+ set data [read $fh 512]
+ while {[regexp {[^\0]} $data]} {
+ array set header [readHeader $data]
+ seek $fh [expr {$header(size) + [pad $header(size)]}] current
+ set data [read $fh 512]
+ }
+ seek $fh -512 current
+ }
foreach x [recurseDirs $files $dereference] {
- writefile $x $fh $dereference
+ writefile $x $fh $dereference $prefix$x
}
puts -nonewline $fh [string repeat \x00 1024]
