steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

support hard links in tar

db4
Doug Coleman 2009-04-29 11:10:58 -05:00
parent 4e46cb18a1
commit cdcaba75da
1 changed files with 15 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
extra/tar/tar.factor
View File

@ -13,7 +13,7 @@ CONSTANT: block-size 512
TUPLE: tar-header name mode uid gid size mtime checksum typeflag TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ; linkname magic version uname gname devmajor devminor prefix ;
ERROR: checksum-error ; ERROR: checksum-error header ;
: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ; : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
@ -60,14 +60,16 @@ ERROR: checksum-error ;
] if ; ] if ;
: parse-tar-header ( seq -- obj ) : parse-tar-header ( seq -- obj )
[ checksum-header ] keep over zero-checksum = [ dup checksum-header dup zero-checksum = [
2drop 2drop
\ tar-header new \ tar-header new
0 >>size 0 >>size
0 >>checksum 0 >>checksum
] [ ] [
[
binary [ read-tar-header ] with-byte-reader binary [ read-tar-header ] with-byte-reader
[ checksum>> = [ checksum-error ] unless ] keep dup checksum>>
] dip = [ checksum-error ] unless
] if ; ] if ;
ERROR: unknown-typeflag ch ; ERROR: unknown-typeflag ch ;
@ -90,7 +92,8 @@ M: unknown-typeflag summary ( obj -- str )
] if ; ] if ;
! Hard link ! Hard link
: typeflag-1 ( header -- ) unknown-typeflag ; : typeflag-1 ( header -- )
[ name>> ] [ linkname>> ] bi make-hard-link ;
! Symlink ! Symlink
: typeflag-2 ( header -- ) : typeflag-2 ( header -- )
@ -141,7 +144,8 @@ M: unknown-typeflag summary ( obj -- str )
! Long file name ! Long file name
: typeflag-L ( header -- ) : typeflag-L ( header -- )
drop ; drop
;
! <string-writer> [ read-data-blocks ] keep ! <string-writer> [ read-data-blocks ] keep
! >string [ zero? ] trim-tail filename set ! >string [ zero? ] trim-tail filename set
! filename get prepend-current-directory make-directories ; ! filename get prepend-current-directory make-directories ;
@ -161,7 +165,7 @@ M: unknown-typeflag summary ( obj -- str )
! Vendor extended header type ! Vendor extended header type
: typeflag-X ( header -- ) unknown-typeflag ; : typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- ) : parse-tar ( -- )
block-size read dup length block-size = [ block-size read dup length block-size = [
parse-tar-header parse-tar-header
dup typeflag>> dup typeflag>>
@ -182,19 +186,19 @@ M: unknown-typeflag summary ( obj -- str )
! { CHAR: E [ typeflag-E ] } ! { CHAR: E [ typeflag-E ] }
! { CHAR: I [ typeflag-I ] } ! { CHAR: I [ typeflag-I ] }
! { CHAR: K [ typeflag-K ] } ! { CHAR: K [ typeflag-K ] }
! { CHAR: L [ typeflag-L ] } { CHAR: L [ typeflag-L ] }
! { CHAR: M [ typeflag-M ] } ! { CHAR: M [ typeflag-M ] }
! { CHAR: N [ typeflag-N ] } ! { CHAR: N [ typeflag-N ] }
! { CHAR: S [ typeflag-S ] } ! { CHAR: S [ typeflag-S ] }
! { CHAR: V [ typeflag-V ] } ! { CHAR: V [ typeflag-V ] }
! { CHAR: X [ typeflag-X ] } ! { CHAR: X [ typeflag-X ] }
{ f [ drop ] } { f [ drop ] }
} case (parse-tar) } case parse-tar
] [ ] [
drop drop
] if ; ] if ;
: untar ( path -- ) : untar ( path -- )
normalize-path [ ] [ parent-directory ] bi [ normalize-path dup parent-directory [
binary [ (parse-tar) ] with-file-reader binary [ parse-tar ] with-file-reader
] with-directory ; ] with-directory ;