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 strings summary ;
+math math.parser namespaces sequences summary typed ;
IN: tar
CONSTANT: zero-checksum 256
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 >string ;
+: 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
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
] 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
] [
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>> prepend-current-directory read/write-blocks ;
+ dup name>> read/write-blocks ;
TUPLE: hard-link linkname name ;
C: <hard-link> hard-link
! Directory
: typeflag-5 ( header -- )
- name>> prepend-current-directory make-directories ;
+ name>> make-directories ;
! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ;
;
! [ read-data-blocks ] with-string-writer
! [ zero? ] trim-tail filename set
- ! filename get prepend-current-directory make-directories ;
+ ! filename get make-directories ;
! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ;
GENERIC: do-link ( object -- )
M: hard-link do-link
- [ linkname>> ]
- [ name>> prepend-current-directory ] bi make-hard-link ;
+ [ linkname>> ] [ name>> ] bi make-hard-link ;
M: symbolic-link do-link
- [ linkname>> ]
- [ name>> prepend-current-directory ] bi make-link ;
+ [ linkname>> ] [ name>> ] bi make-link ;
! FIXME: linux tar calls unlinkat and makelinkat
: make-links ( -- )