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

update tar

db4
Doug Coleman 2009-04-15 19:31:02 -05:00
parent c304660fa9
commit 53397f4f7c
1 changed files with 42 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

73
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 USING: combinators io io.files io.files.links io.directories
io.pathnames io.streams.string kernel math math.parser io.pathnames io.streams.string kernel math math.parser
continuations namespaces pack prettyprint sequences strings continuations namespaces pack prettyprint sequences strings
system tools.hexdump io.encodings.binary summary accessors system tools.hexdump io.encodings.binary summary accessors
io.backend byte-arrays ; io.backend byte-arrays io.streams.byte-array splitting ;
IN: tar IN: tar
CONSTANT: zero-checksum 256 CONSTANT: zero-checksum 256
@ -10,37 +12,35 @@ 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 ;
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 [ zero? ] trim-tail [ f ] when-empty ;
: read-tar-header ( -- obj ) : read-tar-header ( -- obj )
\ tar-header new \ tar-header new
100 read-c-string* >>name 100 read-c-string >>name
8 read-c-string* tar-trim oct> >>mode 8 read-c-string trim-string oct> >>mode
8 read-c-string* tar-trim oct> >>uid 8 read-c-string trim-string oct> >>uid
8 read-c-string* tar-trim oct> >>gid 8 read-c-string trim-string oct> >>gid
12 read-c-string* tar-trim oct> >>size 12 read-c-string trim-string oct> >>size
12 read-c-string* tar-trim oct> >>mtime 12 read-c-string trim-string oct> >>mtime
8 read-c-string* tar-trim oct> >>checksum 8 read-c-string trim-string oct> >>checksum
read1 >>typeflag read1 >>typeflag
100 read-c-string* >>linkname 100 read-c-string >>linkname
6 read >>magic 6 read >>magic
2 read >>version 2 read >>version
32 read-c-string* >>uname 32 read-c-string >>uname
32 read-c-string* >>gname 32 read-c-string >>gname
8 read tar-trim oct> >>devmajor 8 read trim-string oct> >>devmajor
8 read tar-trim oct> >>devminor 8 read trim-string oct> >>devminor
155 read-c-string* >>prefix ; 155 read-c-string >>prefix ;
: header-checksum ( seq -- x ) : checksum-header ( seq -- n )
148 cut-slice 8 tail-slice 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
[ sum ] bi@ + 256 + ;
: read-data-blocks ( tar-header -- ) : read-data-blocks ( tar-header -- )
dup size>> 0 > [ dup size>> 0 > [
@ -60,29 +60,34 @@ SYMBOLS: base-dir filename ;
] if ; ] if ;
: parse-tar-header ( seq -- obj ) : parse-tar-header ( seq -- obj )
[ header-checksum ] keep over zero-checksum = [ [ checksum-header ] keep over zero-checksum = [
2drop 2drop
\ tar-header new \ tar-header new
0 >>size 0 >>size
0 >>checksum 0 >>checksum
] [ ] [
[ read-tar-header ] with-string-reader binary [ read-tar-header ] with-byte-reader
[ checksum>> = [ checksum-error ] unless ] keep [ checksum>> = [ checksum-error ] unless ] keep
] if ; ] if ;
ERROR: unknown-typeflag ch ; ERROR: unknown-typeflag ch ;
M: unknown-typeflag summary ( obj -- str )
ch>> 1string "Unknown typeflag: " prepend ;
: tar-prepend-path ( path -- newpath ) M: unknown-typeflag summary ( obj -- str )
base-dir get prepend-path ; ch>> [ "Unknown typeflag: " ] dip prefix ;
: read/write-blocks ( tar-header path -- ) : read/write-blocks ( tar-header path -- )
binary [ read-data-blocks ] with-file-writer ; binary [ read-data-blocks ] with-file-writer ;
: prepend-current-directory ( path -- path' )
current-directory get prepend-path ;
! Normal file ! Normal file
: typeflag-0 ( header -- ) : typeflag-0 ( header -- )
dup name>> tar-prepend-path read/write-blocks ; dup name>> dup "global_pax_header" = [
drop [ read-data-blocks ] with-string-writer drop
] [
prepend-current-directory read/write-blocks
] if ;
! Hard link ! Hard link
: typeflag-1 ( header -- ) unknown-typeflag ; : typeflag-1 ( header -- ) unknown-typeflag ;
@ -99,7 +104,7 @@ M: unknown-typeflag summary ( obj -- str )
! Directory ! Directory
: typeflag-5 ( header -- ) : typeflag-5 ( header -- )
name>> tar-prepend-path make-directories ; name>> prepend-current-directory make-directories ;
! FIFO ! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ; : typeflag-6 ( header -- ) unknown-typeflag ;
@ -139,7 +144,7 @@ M: unknown-typeflag summary ( obj -- str )
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 tar-prepend-path make-directories ; ! filename get prepend-current-directory make-directories ;
! Multi volume continuation entry ! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ; : typeflag-M ( header -- ) unknown-typeflag ;
@ -157,7 +162,7 @@ M: unknown-typeflag summary ( obj -- str )
: typeflag-X ( header -- ) unknown-typeflag ; : typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- ) : (parse-tar) ( -- )
block-size read dup length 512 = [ block-size read dup length block-size = [
parse-tar-header parse-tar-header
dup typeflag>> dup typeflag>>
{ {
@ -189,7 +194,7 @@ M: unknown-typeflag summary ( obj -- str )
drop drop
] if ; ] if ;
: parse-tar ( path -- ) : untar ( path -- )
normalize-path dup parent-directory base-dir [ normalize-path [ ] [ parent-directory ] bi [
binary [ (parse-tar) ] with-file-reader binary [ (parse-tar) ] with-file-reader
] with-variable ; ] with-directory ;