 USING: combinators io io.files io.streams.string kernel math
 math.parser continuations namespaces pack prettyprint sequences
-strings system hexdump io.encodings.binary inspector accessors ;
+strings system hexdump io.encodings.binary inspector accessors
+io.backend symbols byte-arrays ;
 IN: tar
 
-: zero-checksum 256 ;
+: zero-checksum 256 ; inline
+: block-size 512 ; inline
 
 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
 linkname magic version uname gname devmajor devminor prefix ;
+ERROR: checksum-error ;
 
-: <tar-header> ( -- obj ) tar-header new ;
+SYMBOLS: base-dir filename ;
 
-: tar-trim ( seq -- newseq )
-    [ "\0 " member? ] trim ;
+: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
 
 : read-tar-header ( -- obj )
-    <tar-header>
-    100 read-c-string* over set-tar-header-name
-    8 read-c-string* tar-trim oct> over set-tar-header-mode
-    8 read-c-string* tar-trim oct> over set-tar-header-uid
-    8 read-c-string* tar-trim oct> over set-tar-header-gid
-    12 read-c-string* tar-trim oct> over set-tar-header-size
-    12 read-c-string* tar-trim oct> over set-tar-header-mtime
-    8 read-c-string* tar-trim oct> over set-tar-header-checksum
-    read1 over set-tar-header-typeflag
-    100 read-c-string* over set-tar-header-linkname
-    6 read over set-tar-header-magic
-    2 read over set-tar-header-version
-    32 read-c-string* over set-tar-header-uname
-    32 read-c-string* over set-tar-header-gname
-    8 read tar-trim oct> over set-tar-header-devmajor
-    8 read tar-trim oct> over set-tar-header-devminor
-    155 read-c-string* over set-tar-header-prefix ;
+    \ 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 ;
 
 : header-checksum ( seq -- x )
     148 cut-slice 8 tail-slice
     [ sum ] bi@ + 256 + ;
 
-TUPLE: checksum-error ;
-TUPLE: malformed-block-error ;
-
-SYMBOL: base-dir
-SYMBOL: out-stream
-SYMBOL: filename
-
-: (read-data-blocks) ( tar-header -- )
-    512 read [
-        over tar-header-size dup 512 <= [
-            head-slice 
-            >string write
-            drop
+: read-data-blocks ( tar-header -- )
+    dup size>> 0 > [
+        block-size read [
+            over size>> dup block-size <= [
+                head-slice >byte-array write drop
+            ] [
+                drop write
+                [ block-size - ] change-size
+                read-data-blocks
+            ] if
         ] [
             drop
-            >string write
-            dup tar-header-size 512 - over set-tar-header-size
-            (read-data-blocks)
-        ] if
+        ] if*
     ] [
         drop
-    ] if* ;
-
-: read-data-blocks ( tar-header out -- )
-    [ (read-data-blocks) ] with-output-stream* ;
+    ] if ;
 
 : parse-tar-header ( seq -- obj )
     [ header-checksum ] keep over zero-checksum = [
         2drop
         \ tar-header new
-        0 over set-tar-header-size
-        0 over set-tar-header-checksum
+            0 >>size
+            0 >>checksum
     ] [
         [ read-tar-header ] with-string-reader
-        [ tar-header-checksum = [
-                \ checksum-error new throw
-            ] unless
-        ] keep
+        [ checksum>> = [ checksum-error ] unless ] keep
     ] if ;
 
 ERROR: unknown-typeflag ch ;
 M: unknown-typeflag summary ( obj -- str )
-    ch>> 1string
-    "Unknown typeflag: " prepend ;
+    ch>> 1string "Unknown typeflag: " prepend ;
 
-: tar-append-path ( path -- newpath )
+: tar-prepend-path ( path -- newpath )
     base-dir get prepend-path ;
 
+: read/write-blocks ( tar-header path -- )
+    binary [ read-data-blocks ] with-file-writer ;
+
 ! Normal file
-: typeflag-0
-  name>> tar-append-path binary <file-writer>
-  [ read-data-blocks ] keep dispose ;
+: typeflag-0 ( header -- )
+    dup name>> tar-prepend-path read/write-blocks ;
 
 ! Hard link
 : typeflag-1 ( header -- ) unknown-typeflag ;
 
 ! Symlink
-: typeflag-2 ( header -- ) unknown-typeflag ;
+: typeflag-2 ( header -- )
+    [ name>> ] [ linkname>> ] bi
+    [ make-link ] 2curry ignore-errors ;
 
 ! character special
 : typeflag-3 ( header -- ) unknown-typeflag ;

: typeflag-X ( header -- ) unknown-typeflag ;

: (parse-tar) ( -- )
    512 read 
    global [ dup hexdump. flush ] bind
    [
        parse-tar-header
        ! global [ dup tar-header-name [ print flush ] when* ] bind 
        dup tar-header-typeflag
        {
            { 0 [ typeflag-0 ] }
            { CHAR: 0 [ typeflag-0 ] }
            { CHAR: 1 [ typeflag-1 ] }
            { CHAR: 2 [ typeflag-2 ] }
            { CHAR: 3 [ typeflag-3 ] }
            { CHAR: 4 [ typeflag-4 ] }
            { CHAR: 5 [ typeflag-5 ] }
            { CHAR: 6 [ typeflag-6 ] }
            { CHAR: 7 [ typeflag-7 ] }
            { CHAR: g [ typeflag-g ] }
            { CHAR: x [ typeflag-x ] }
            { CHAR: A [ typeflag-A ] }
            { CHAR: D [ typeflag-D ] }
            { CHAR: E [ typeflag-E ] }
            { CHAR: I [ typeflag-I ] }
            { CHAR: K [ typeflag-K ] }
            { CHAR: L [ typeflag-L ] }
            { CHAR: M [ typeflag-M ] }
            { CHAR: N [ typeflag-N ] }
            { CHAR: S [ typeflag-S ] }
            { CHAR: V [ typeflag-V ] }
            { CHAR: X [ typeflag-X ] }
            [ unknown-typeflag ]
        } case
        ! dup tar-header-size zero? [
            ! out-stream get [ dispose ] when
            ! out-stream off
            ! drop
        ! ] [
            ! dup tar-header-name
            ! dup parent-dir base-dir prepend-path
            ! global [ dup [ . flush ] when* ] bind 
            ! make-directories <file-writer>
            ! out-stream set
            ! read-tar-blocks
        ! ] if
        (parse-tar)
    ] when* ;

: parse-tar ( path -- obj )
    binary [
        "resource:tar-test" base-dir set
        global [ nl nl nl "Starting to parse .tar..." print flush ] bind
        global [ "Expanding to: " write base-dir get . flush ] bind
        (parse-tar)
    ] with-file-writer ;


! Long file name
: typeflag-L ( header -- )
    drop ;
    ! <string-writer> [ read-data-blocks ] keep
    ! >string [ zero? ] right-trim filename set
    ! filename get tar-prepend-path make-directories ;

! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ;
