2008-05-05 03:19:25 -04:00
|
|
|
USING: combinators io io.files io.streams.string kernel math
|
|
|
|
math.parser continuations namespaces pack prettyprint sequences
|
2008-11-13 20:49:34 -05:00
|
|
|
strings system tools.hexdump io.encodings.binary summary accessors
|
2008-05-09 22:11:27 -04:00
|
|
|
io.backend symbols byte-arrays ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: tar
|
|
|
|
|
2008-05-09 22:11:27 -04:00
|
|
|
: zero-checksum 256 ; inline
|
|
|
|
: block-size 512 ; inline
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
|
|
|
|
linkname magic version uname gname devmajor devminor prefix ;
|
2008-05-09 22:11:27 -04:00
|
|
|
ERROR: checksum-error ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-05-09 22:11:27 -04:00
|
|
|
SYMBOLS: base-dir filename ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-05-09 22:11:27 -04:00
|
|
|
: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: read-tar-header ( -- obj )
|
2008-05-09 22:11:27 -04:00
|
|
|
\ 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 ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: header-checksum ( seq -- x )
|
2007-10-12 16:30:36 -04:00
|
|
|
148 cut-slice 8 tail-slice
|
2008-03-29 21:36:58 -04:00
|
|
|
[ sum ] bi@ + 256 + ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-05-09 22:11:27 -04:00
|
|
|
: read-data-blocks ( tar-header -- )
|
|
|
|
dup size>> 0 > [
|
|
|
|
block-size read [
|
|
|
|
over size>> dup block-size <= [
|
|
|
|
head-slice >byte-array write drop
|
|
|
|
] [
|
|
|
|
drop write
|
|
|
|
[ block-size - ] change-size
|
|
|
|
read-data-blocks
|
|
|
|
] if
|
2007-09-20 18:09:08 -04:00
|
|
|
] [
|
|
|
|
drop
|
2008-05-09 22:11:27 -04:00
|
|
|
] if*
|
2007-09-20 18:09:08 -04:00
|
|
|
] [
|
|
|
|
drop
|
2008-05-09 22:11:27 -04:00
|
|
|
] if ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: parse-tar-header ( seq -- obj )
|
|
|
|
[ header-checksum ] keep over zero-checksum = [
|
|
|
|
2drop
|
2008-04-13 16:06:27 -04:00
|
|
|
\ tar-header new
|
2008-05-09 22:11:27 -04:00
|
|
|
0 >>size
|
|
|
|
0 >>checksum
|
2007-09-20 18:09:08 -04:00
|
|
|
] [
|
2008-02-15 23:20:31 -05:00
|
|
|
[ read-tar-header ] with-string-reader
|
2008-05-09 22:11:27 -04:00
|
|
|
[ checksum>> = [ checksum-error ] unless ] keep
|
2007-09-20 18:09:08 -04:00
|
|
|
] if ;
|
|
|
|
|
2008-04-11 13:53:46 -04:00
|
|
|
ERROR: unknown-typeflag ch ;
|
|
|
|
M: unknown-typeflag summary ( obj -- str )
|
2008-05-09 22:11:27 -04:00
|
|
|
ch>> 1string "Unknown typeflag: " prepend ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-05-09 22:11:27 -04:00
|
|
|
: tar-prepend-path ( path -- newpath )
|
2008-03-19 20:15:32 -04:00
|
|
|
base-dir get prepend-path ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-05-09 22:11:27 -04:00
|
|
|
: read/write-blocks ( tar-header path -- )
|
|
|
|
binary [ read-data-blocks ] with-file-writer ;
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
! Normal file
|
2008-05-09 22:11:27 -04:00
|
|
|
: typeflag-0 ( header -- )
|
|
|
|
dup name>> tar-prepend-path read/write-blocks ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Hard link
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-1 ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Symlink
|
2008-05-09 22:11:27 -04:00
|
|
|
: typeflag-2 ( header -- )
|
|
|
|
[ name>> ] [ linkname>> ] bi
|
|
|
|
[ make-link ] 2curry ignore-errors ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! character special
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-3 ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Block special
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-4 ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Directory
|
|
|
|
: typeflag-5 ( header -- )
|
2008-05-09 22:11:27 -04:00
|
|
|
name>> tar-prepend-path make-directories ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! FIFO
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-6 ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Contiguous file
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-7 ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Global extended header
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-8 ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Extended header
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-9 ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Global POSIX header
|
2008-05-09 22:11:27 -04:00
|
|
|
: typeflag-g ( header -- ) typeflag-0 ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Extended POSIX header
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-x ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Solaris access control list
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-A ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! GNU dumpdir
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-D ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Solaris extended attribute file
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-E ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Inode metadata
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-I ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Long link name
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-K ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Long file name
|
|
|
|
: typeflag-L ( header -- )
|
2008-05-09 22:11:27 -04:00
|
|
|
drop ;
|
|
|
|
! <string-writer> [ read-data-blocks ] keep
|
2008-09-05 19:56:57 -04:00
|
|
|
! >string [ zero? ] trim-right filename set
|
2008-05-09 22:11:27 -04:00
|
|
|
! filename get tar-prepend-path make-directories ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Multi volume continuation entry
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-M ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! GNU long file name
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-N ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Sparse file
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-S ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Volume header
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-V ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Vendor extended header type
|
2008-04-11 13:53:46 -04:00
|
|
|
: typeflag-X ( header -- ) unknown-typeflag ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
: (parse-tar) ( -- )
|
2008-05-09 22:11:27 -04:00
|
|
|
block-size read dup length 512 = [
|
2007-09-20 18:09:08 -04:00
|
|
|
parse-tar-header
|
2008-05-09 22:11:27 -04:00
|
|
|
dup typeflag>>
|
2007-09-20 18:09:08 -04:00
|
|
|
{
|
2008-01-12 17:23:34 -05:00
|
|
|
{ 0 [ typeflag-0 ] }
|
2007-09-20 18:09:08 -04:00
|
|
|
{ CHAR: 0 [ typeflag-0 ] }
|
2008-05-09 22:11:27 -04:00
|
|
|
! { CHAR: 1 [ typeflag-1 ] }
|
2007-09-20 18:09:08 -04:00
|
|
|
{ CHAR: 2 [ typeflag-2 ] }
|
2008-05-09 22:11:27 -04:00
|
|
|
! { CHAR: 3 [ typeflag-3 ] }
|
|
|
|
! { CHAR: 4 [ typeflag-4 ] }
|
2007-09-20 18:09:08 -04:00
|
|
|
{ CHAR: 5 [ typeflag-5 ] }
|
2008-05-09 22:11:27 -04:00
|
|
|
! { CHAR: 6 [ typeflag-6 ] }
|
|
|
|
! { CHAR: 7 [ typeflag-7 ] }
|
2007-09-20 18:09:08 -04:00
|
|
|
{ CHAR: g [ typeflag-g ] }
|
2008-05-09 22:11:27 -04:00
|
|
|
! { 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 ] }
|
|
|
|
{ f [ drop ] }
|
|
|
|
} case (parse-tar)
|
|
|
|
] [
|
|
|
|
drop
|
|
|
|
] if ;
|
|
|
|
|
|
|
|
: parse-tar ( path -- )
|
|
|
|
normalize-path dup parent-directory base-dir [
|
|
|
|
binary [ (parse-tar) ] with-file-reader
|
|
|
|
] with-variable ;
|