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

fix up tar

db4
Doug Coleman 2009-04-14 22:47:39 -05:00
parent a59841e04e
commit 8644c98549
1 changed files with 41 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
extra/tar/tar.factor
View File

@ -1,8 +1,10 @@
! 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.backend byte-arrays io.streams.byte-array splitting ;
IN: tar
CONSTANT: zero-checksum 256
@ -10,37 +12,35 @@ CONSTANT: block-size 512
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
ERROR: checksum-error ;
SYMBOLS: base-dir filename ;
: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
: read-c-string* ( n -- str/f )
: read-c-string ( n -- str/f )
read [ zero? ] trim-tail [ f ] when-empty ;
: read-tar-header ( -- obj )
\ 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 ;
100 read-c-string >>name
8 read-c-string trim-string oct> >>mode
8 read-c-string trim-string oct> >>uid
8 read-c-string trim-string oct> >>gid
12 read-c-string trim-string oct> >>size
12 read-c-string trim-string oct> >>mtime
8 read-c-string trim-string 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 trim-string oct> >>devmajor
8 read trim-string oct> >>devminor
155 read-c-string >>prefix ;
: header-checksum ( seq -- x )
148 cut-slice 8 tail-slice
[ sum ] bi@ + 256 + ;
: checksum-header ( seq -- n )
148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
: read-data-blocks ( tar-header -- )
dup size>> 0 > [
@ -60,29 +60,33 @@ SYMBOLS: base-dir filename ;
] if ;
: parse-tar-header ( seq -- obj )
[ header-checksum ] keep over zero-checksum = [
[ checksum-header ] keep over zero-checksum = [
2drop
\ tar-header new
0 >>size
0 >>checksum
] [
[ read-tar-header ] with-string-reader
binary [ read-tar-header ] with-byte-reader
[ checksum>> = [ checksum-error ] unless ] keep
] if ;
ERROR: unknown-typeflag ch ;
M: unknown-typeflag summary ( obj -- str )
ch>> 1string "Unknown typeflag: " prepend ;
: tar-prepend-path ( path -- newpath )
base-dir get prepend-path ;
ch>> "Unknown typeflag: " prefix ;
: read/write-blocks ( tar-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>> tar-prepend-path read/write-blocks ;
dup name>> dup global_pax_header = [
[ read-data-blocks ] with-string-writer drop
] [
prepend-current-directory read/write-blocks
] if ;
! Hard link
: typeflag-1 ( header -- ) unknown-typeflag ;
@ -99,7 +103,7 @@ M: unknown-typeflag summary ( obj -- str )
! Directory
: typeflag-5 ( header -- )
name>> tar-prepend-path make-directories ;
name>> prepend-current-directory make-directories ;
! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ;
@ -139,7 +143,7 @@ M: unknown-typeflag summary ( obj -- str )
drop ;
! <string-writer> [ read-data-blocks ] keep
! >string [ zero? ] trim-tail filename set
! filename get tar-prepend-path make-directories ;
! filename get prepend-current-directory make-directories ;
! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ;
@ -157,7 +161,7 @@ M: unknown-typeflag summary ( obj -- str )
: typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- )
block-size read dup length 512 = [
block-size read dup length block-size = [
parse-tar-header
dup typeflag>>
{
@ -189,7 +193,7 @@ M: unknown-typeflag summary ( obj -- str )
drop
] if ;
: parse-tar ( path -- )
normalize-path dup parent-directory base-dir [
: untar ( path -- )
normalize-path [ ] [ parent-directory ] bi [
binary [ (parse-tar) ] with-file-reader
] with-variable ;
] with-directory ;