USING: combinators io io.files io.streams.duplex io.streams.string kernel math math.parser namespaces pack prettyprint sequences strings system ; USING: hexdump tools.interpreter ; IN: tar : zero-checksum 256 ; TUPLE: tar-header name mode uid gid size mtime checksum typeflag linkname magic version uname gname devmajor devminor prefix ; : ( -- obj ) tar-header construct-empty ; : tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ; : read-tar-header ( -- obj ) 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 ; : header-checksum ( seq -- x ) 148 cut-slice 8 tail-slice [ 0 [ + ] reduce ] 2apply + 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 ] [ drop >string write dup tar-header-size 512 - over set-tar-header-size (read-data-blocks) ] if ] [ drop ] if* ; : read-data-blocks ( tar-header out -- ) >r stdio get r> [ (read-data-blocks) ] with-stream* ; : parse-tar-header ( seq -- obj ) [ header-checksum ] keep over zero-checksum = [ 2drop \ tar-header construct-empty 0 over set-tar-header-size 0 over set-tar-header-checksum ] [ [ read-tar-header ] string-in [ tar-header-checksum = [ \ checksum-error construct-empty throw ] unless ] keep ] if ; TUPLE: unknown-typeflag str ; : ( ch -- obj ) 1string \ unknown-typeflag construct-boa ; TUPLE: unimplemented-typeflag header ; : ( header -- obj ) global [ "Unimplemented typeflag: " print dup . flush ] bind tar-header-typeflag 1string \ unimplemented-typeflag construct-boa ; : tar-path+ ( path -- newpath ) base-dir get swap path+ ; ! Normal file : typeflag-0 tar-header-name tar-path+ [ read-data-blocks ] keep stream-close ; ! Hard link : typeflag-1 ( header -- ) throw ; ! Symlink : typeflag-2 ( header -- ) throw ; ! character special : typeflag-3 ( header -- ) throw ; ! Block special : typeflag-4 ( header -- ) throw ; ! Directory : typeflag-5 ( header -- ) tar-header-name tar-path+ make-directories ; ! FIFO : typeflag-6 ( header -- ) throw ; ! Contiguous file : typeflag-7 ( header -- ) throw ; ! Global extended header : typeflag-8 ( header -- ) throw ; ! Extended header : typeflag-9 ( header -- ) throw ; ! Global POSIX header : typeflag-g ( header -- ) throw ; ! Extended POSIX header : typeflag-x ( header -- ) throw ; ! Solaris access control list : typeflag-A ( header -- ) throw ; ! GNU dumpdir : typeflag-D ( header -- ) throw ; ! Solaris extended attribute file : typeflag-E ( header -- ) throw ; ! Inode metadata : typeflag-I ( header -- ) throw ; ! Long link name : typeflag-K ( header -- ) throw ; ! Long file name : typeflag-L ( header -- ) [ read-data-blocks ] keep >string [ CHAR: \0 = ] right-trim filename set global [ "long filename: " write filename get . flush ] bind filename get tar-path+ make-directories ; ! Multi volume continuation entry : typeflag-M ( header -- ) throw ; ! GNU long file name : typeflag-N ( header -- ) throw ; ! Sparse file : typeflag-S ( header -- ) throw ; ! Volume header : typeflag-V ( header -- ) throw ; ! Vendor extended header type : typeflag-X ( header -- ) throw ; : (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 { { CHAR: \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 ] } [ throw ] } case ! dup tar-header-size zero? [ ! out-stream get [ stream-close ] when ! out-stream off ! drop ! ] [ ! dup tar-header-name ! dup parent-dir base-dir swap path+ ! global [ dup [ . flush ] when* ] bind ! make-directories ! out-stream set ! read-tar-blocks ! ] if (parse-tar) ] when* ; : parse-tar ( path -- obj ) [ "tar-test" resource-path 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-stream ;