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]
 
