From 8644c9854938dcb1efb1cd2c253cc0e06e308dd0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 14 Apr 2009 22:47:39 -0500
Subject: [PATCH] fix up tar

---
 extra/tar/tar.factor | 78 +++++++++++++++++++++++---------------------
 1 file changed, 41 insertions(+), 37 deletions(-)

diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
index 37c022fe43..e83908b002 100755
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@@ -1,8 +1,10 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: combinators io io.files io.files.links io.directories
 io.pathnames io.streams.string kernel math math.parser
 continuations namespaces pack prettyprint sequences strings
 system tools.hexdump io.encodings.binary summary accessors
-io.backend byte-arrays ;
+io.backend byte-arrays io.streams.byte-array splitting ;
 IN: tar
 
 CONSTANT: zero-checksum 256
@@ -10,37 +12,35 @@ CONSTANT: block-size 512
 
 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
 linkname magic version uname gname devmajor devminor prefix ;
+
 ERROR: checksum-error ;
 
-SYMBOLS: base-dir filename ;
+: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
 
-: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
-
-: read-c-string* ( n -- str/f )
+: read-c-string ( n -- str/f )
     read [ zero? ] trim-tail [ f ] when-empty ;
 
 : read-tar-header ( -- obj )
     \ tar-header new
-    100 read-c-string* >>name
-    8 read-c-string* tar-trim oct> >>mode
-    8 read-c-string* tar-trim oct> >>uid
-    8 read-c-string* tar-trim oct> >>gid
-    12 read-c-string* tar-trim oct> >>size
-    12 read-c-string* tar-trim oct> >>mtime
-    8 read-c-string* tar-trim oct> >>checksum
-    read1 >>typeflag
-    100 read-c-string* >>linkname
-    6 read >>magic
-    2 read >>version
-    32 read-c-string* >>uname
-    32 read-c-string* >>gname
-    8 read tar-trim oct> >>devmajor
-    8 read tar-trim oct> >>devminor
-    155 read-c-string* >>prefix ;
+        100 read-c-string >>name
+        8 read-c-string trim-string oct> >>mode
+        8 read-c-string trim-string oct> >>uid
+        8 read-c-string trim-string oct> >>gid
+        12 read-c-string trim-string oct> >>size
+        12 read-c-string trim-string oct> >>mtime
+        8 read-c-string trim-string oct> >>checksum
+        read1 >>typeflag
+        100 read-c-string >>linkname
+        6 read >>magic
+        2 read >>version
+        32 read-c-string >>uname
+        32 read-c-string >>gname
+        8 read trim-string oct> >>devmajor
+        8 read trim-string oct> >>devminor
+        155 read-c-string >>prefix ;
 
-: header-checksum ( seq -- x )
-    148 cut-slice 8 tail-slice
-    [ sum ] bi@ + 256 + ;
+: checksum-header ( seq -- n )
+    148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
 
 : read-data-blocks ( tar-header -- )
     dup size>> 0 > [
@@ -60,29 +60,33 @@ SYMBOLS: base-dir filename ;
     ] if ;
 
 : parse-tar-header ( seq -- obj )
-    [ header-checksum ] keep over zero-checksum = [
+    [ checksum-header ] keep over zero-checksum = [
         2drop
         \ tar-header new
             0 >>size
             0 >>checksum
     ] [
-        [ read-tar-header ] with-string-reader
+        binary [ read-tar-header ] with-byte-reader
         [ checksum>> = [ checksum-error ] unless ] keep
     ] if ;
 
 ERROR: unknown-typeflag ch ;
 M: unknown-typeflag summary ( obj -- str )
-    ch>> 1string "Unknown typeflag: " prepend ;
-
-: tar-prepend-path ( path -- newpath )
-    base-dir get prepend-path ;
+    ch>> "Unknown typeflag: " prefix ;
 
 : read/write-blocks ( tar-header path -- )
     binary [ read-data-blocks ] with-file-writer ;
 
+: prepend-current-directory ( path -- path' )
+    current-directory get prepend-path ;
+
 ! Normal file
 : typeflag-0 ( header -- )
-    dup name>> tar-prepend-path read/write-blocks ;
+    dup name>> dup global_pax_header = [
+        [ read-data-blocks ] with-string-writer drop
+    ] [
+        prepend-current-directory read/write-blocks
+    ] if ;
 
 ! Hard link
 : typeflag-1 ( header -- ) unknown-typeflag ;
@@ -99,7 +103,7 @@ M: unknown-typeflag summary ( obj -- str )
 
 ! Directory
 : typeflag-5 ( header -- )
-    name>> tar-prepend-path make-directories ;
+    name>> prepend-current-directory make-directories ;
 
 ! FIFO
 : typeflag-6 ( header -- ) unknown-typeflag ;
@@ -139,7 +143,7 @@ M: unknown-typeflag summary ( obj -- str )
     drop ;
     ! <string-writer> [ read-data-blocks ] keep
     ! >string [ zero? ] trim-tail filename set
-    ! filename get tar-prepend-path make-directories ;
+    ! filename get prepend-current-directory make-directories ;
 
 ! Multi volume continuation entry
 : typeflag-M ( header -- ) unknown-typeflag ;
@@ -157,7 +161,7 @@ M: unknown-typeflag summary ( obj -- str )
 : typeflag-X ( header -- ) unknown-typeflag ;
 
 : (parse-tar) ( -- )
-    block-size read dup length 512 = [
+    block-size read dup length block-size = [
         parse-tar-header
         dup typeflag>>
         {
@@ -189,7 +193,7 @@ M: unknown-typeflag summary ( obj -- str )
         drop
     ] if ;
 
-: parse-tar ( path -- )
-    normalize-path dup parent-directory base-dir [
+: untar ( path -- )
+    normalize-path [ ] [ parent-directory ] bi [
          binary [ (parse-tar) ] with-file-reader
-    ] with-variable ;
+    ] with-directory ;