factor: trim using lists

[factor.git] / extra / tar / tar.factor

diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
old mode 100755 (executable)
new mode 100644 (file)
index e281871..45570dc
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@@ -1,27 +1,31 @@
 ! 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.streams.byte-array splitting ;
+USING: accessors byte-arrays combinators io io.backend
+io.directories io.encodings.binary io.files io.files.links
+io.pathnames io.streams.byte-array io.streams.string kernel
+math math.parser namespaces sequences summary typed ;
 IN: tar
 
 CONSTANT: zero-checksum 256
 CONSTANT: block-size 512
 
+SYMBOL: to-link
+
+: save-link ( link -- )
+    to-link get push ;
+
 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
 linkname magic version uname gname devmajor devminor prefix ;
 
 ERROR: checksum-error header ;
 
-: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
+: trim-string ( seq -- newseq ) [ "\0 " member? ] trim-tail ;
 
-: read-c-string ( n -- str/f )
-    read [ zero? ] trim-tail [ f ] when-empty ;
+: read-c-string ( n -- str )
+    read [ zero? ] trim-tail "" like ;
 
-: read-tar-header ( -- obj )
-    \ tar-header new
+: read-tar-header ( -- header )
+    tar-header new
         100 read-c-string >>name
         8 read-c-string trim-string oct> >>mode
         8 read-c-string trim-string oct> >>uid
@@ -39,14 +43,14 @@ ERROR: checksum-error header ;
         8 read trim-string oct> >>devminor
         155 read-c-string >>prefix ;
 
-: checksum-header ( seq -- n )
-    148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
+TYPED: checksum-header ( seq: byte-array -- n )
+    148 cut-slice 8 tail-slice [ 0 [ + ] reduce ] bi@ + 256 + >fixnum ;
 
-: read-data-blocks ( tar-header -- )
+: read-data-blocks ( header -- )
     dup size>> 0 > [
         block-size read [
             over size>> dup block-size <= [
-                head-slice >byte-array write drop
+                head write drop
             ] [
                 drop write
                 [ block-size - ] change-size
@@ -57,12 +61,12 @@ ERROR: checksum-error header ;
         ] if*
     ] [
         drop
-    ] if ;
+    ] if ; inline recursive
 
-: parse-tar-header ( seq -- obj )
+: parse-tar-header ( seq -- header )
     dup checksum-header dup zero-checksum = [
         2drop
-        \ tar-header new
+        tar-header new
             0 >>size
             0 >>checksum
     ] [
@@ -74,30 +78,29 @@ ERROR: checksum-error header ;
 
 ERROR: unknown-typeflag ch ;
 
-M: unknown-typeflag summary ( obj -- str )
+M: unknown-typeflag summary
     ch>> [ "Unknown typeflag: " ] dip prefix ;
 
-: read/write-blocks ( tar-header path -- )
+: read/write-blocks ( 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>> dup "global_pax_header" = [
-        drop [ read-data-blocks ] with-string-writer drop
-    ] [
-        prepend-current-directory read/write-blocks
-    ] if ;
+    dup name>> read/write-blocks ;
 
-! Hard link
+TUPLE: hard-link linkname name ;
+C: <hard-link> hard-link
+
+TUPLE: symbolic-link linkname name ;
+C: <symbolic-link> symbolic-link
+
+! Hard link, don't call normalize-path
 : typeflag-1 ( header -- )
-    [ name>> ] [ linkname>> ] bi make-hard-link ;
+    [ linkname>> ] [ name>> ] bi <hard-link> save-link ;
 
-! Symlink
+! Symlink, don't call normalize-path
 : typeflag-2 ( header -- )
-    [ name>> ] [ linkname>> ] bi make-link ;
+    [ linkname>> ] [ name>> ] bi <symbolic-link> save-link ;
 
 ! character special
 : typeflag-3 ( header -- ) unknown-typeflag ;
@@ -107,7 +110,7 @@ M: unknown-typeflag summary ( obj -- str )
 
 ! Directory
 : typeflag-5 ( header -- )
-    name>> prepend-current-directory make-directories ;
+    name>> make-directories ;
 
 ! FIFO
 : typeflag-6 ( header -- ) unknown-typeflag ;
@@ -122,7 +125,10 @@ M: unknown-typeflag summary ( obj -- str )
 : typeflag-9 ( header -- ) unknown-typeflag ;
 
 ! Global POSIX header
-: typeflag-g ( header -- ) typeflag-0 ;
+: typeflag-g ( header -- )
+    ! Read something like: 52 comment=9f2a940965286754f3a34d5737c3097c05db8725
+    ! and drop it
+    [ read-data-blocks ] with-string-writer drop ;
 
 ! Extended POSIX header
 : typeflag-x ( header -- ) unknown-typeflag ;
@@ -146,9 +152,9 @@ M: unknown-typeflag summary ( obj -- str )
 : typeflag-L ( header -- )
     drop
     ;
-    ! <string-writer> [ read-data-blocks ] keep
-    ! >string [ zero? ] trim-tail filename set
-    ! filename get prepend-current-directory make-directories ;
+    ! [ read-data-blocks ] with-string-writer
+    ! [ zero? ] trim-tail filename set
+    ! filename get make-directories ;
 
 ! Multi volume continuation entry
 : typeflag-M ( header -- ) unknown-typeflag ;
@@ -198,7 +204,24 @@ M: unknown-typeflag summary ( obj -- str )
         drop
     ] if ;
 
+GENERIC: do-link ( object -- )
+
+M: hard-link do-link
+    [ linkname>> ] [ name>> ] bi make-hard-link ;
+
+M: symbolic-link do-link
+    [ linkname>> ] [ name>> ] bi make-link ;
+
+! FIXME: linux tar calls unlinkat and makelinkat
+: make-links ( -- )
+    to-link get [
+        [ name>> ?delete-file ] [ do-link ] bi
+    ] each ;
+
 : untar ( path -- )
     normalize-path dup parent-directory [
-         binary [ parse-tar ] with-file-reader
+        V{ } clone to-link [
+            binary [ parse-tar ] with-file-reader
+            make-links
+        ] with-variable
     ] with-directory ;