factor/extra/tar/tar.factor

205 lines
5.5 KiB
Factor
Raw Normal View History

2009-04-15 20:31:02 -04:00
! 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
2009-04-15 20:31:02 -04:00
io.backend byte-arrays io.streams.byte-array splitting ;
2007-09-20 18:09:08 -04:00
IN: tar
CONSTANT: zero-checksum 256
CONSTANT: block-size 512
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 ;
2009-04-29 12:10:58 -04:00
ERROR: checksum-error header ;
2007-09-20 18:09:08 -04:00
2009-04-15 20:31:02 -04:00
: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
2007-09-20 18:09:08 -04:00
2009-04-15 20:31:02 -04:00
: read-c-string ( n -- str/f )
read [ zero? ] trim-tail [ f ] when-empty >string ;
2009-01-19 23:26:46 -05:00
2007-09-20 18:09:08 -04:00
: read-tar-header ( -- obj )
\ tar-header new
2009-04-15 20:31:02 -04:00
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 ;
: checksum-header ( seq -- n )
148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
2007-09-20 18:09:08 -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
] if*
2007-09-20 18:09:08 -04:00
] [
drop
] if ;
2007-09-20 18:09:08 -04:00
: parse-tar-header ( seq -- obj )
2009-04-29 12:10:58 -04:00
dup checksum-header dup zero-checksum = [
2007-09-20 18:09:08 -04:00
2drop
\ tar-header new
0 >>size
0 >>checksum
2007-09-20 18:09:08 -04:00
] [
2009-04-29 12:10:58 -04:00
[
binary [ read-tar-header ] with-byte-reader
dup checksum>>
] dip = [ checksum-error ] unless
2007-09-20 18:09:08 -04:00
] if ;
2008-04-11 13:53:46 -04:00
ERROR: unknown-typeflag ch ;
2007-09-20 18:09:08 -04:00
2009-04-15 20:31:02 -04:00
M: unknown-typeflag summary ( obj -- str )
ch>> [ "Unknown typeflag: " ] dip prefix ;
2007-09-20 18:09:08 -04:00
: read/write-blocks ( tar-header path -- )
binary [ read-data-blocks ] with-file-writer ;
2009-04-15 20:31:02 -04:00
: prepend-current-directory ( path -- path' )
current-directory get prepend-path ;
2007-09-20 18:09:08 -04:00
! Normal file
: typeflag-0 ( header -- )
2009-04-15 20:31:02 -04:00
dup name>> dup "global_pax_header" = [
drop [ read-data-blocks ] with-string-writer drop
] [
prepend-current-directory read/write-blocks
] if ;
2007-09-20 18:09:08 -04:00
! Hard link
2009-04-29 12:10:58 -04:00
: typeflag-1 ( header -- )
[ name>> ] [ linkname>> ] bi make-hard-link ;
2007-09-20 18:09:08 -04:00
! Symlink
: typeflag-2 ( header -- )
[ name>> ] [ linkname>> ] bi make-link ;
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 -- )
2009-04-15 20:31:02 -04:00
name>> prepend-current-directory 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
: 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 -- )
2009-04-29 12:10:58 -04:00
drop
;
! <string-writer> [ read-data-blocks ] keep
! >string [ zero? ] trim-tail filename set
2009-04-15 20:31:02 -04:00
! filename get prepend-current-directory 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
2009-04-29 12:10:58 -04:00
: parse-tar ( -- )
2009-04-15 20:31:02 -04:00
block-size read dup length block-size = [
2007-09-20 18:09:08 -04:00
parse-tar-header
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 ] }
! { CHAR: 1 [ typeflag-1 ] }
2007-09-20 18:09:08 -04:00
{ CHAR: 2 [ typeflag-2 ] }
! { CHAR: 3 [ typeflag-3 ] }
! { CHAR: 4 [ typeflag-4 ] }
2007-09-20 18:09:08 -04:00
{ CHAR: 5 [ typeflag-5 ] }
! { CHAR: 6 [ typeflag-6 ] }
! { CHAR: 7 [ typeflag-7 ] }
2007-09-20 18:09:08 -04:00
{ CHAR: g [ typeflag-g ] }
! { CHAR: x [ typeflag-x ] }
! { CHAR: A [ typeflag-A ] }
! { CHAR: D [ typeflag-D ] }
! { CHAR: E [ typeflag-E ] }
! { CHAR: I [ typeflag-I ] }
! { CHAR: K [ typeflag-K ] }
2009-04-29 12:10:58 -04:00
{ 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 ] }
2009-04-29 12:10:58 -04:00
} case parse-tar
] [
drop
] if ;
2009-04-15 20:31:02 -04:00
: untar ( path -- )
2009-04-29 12:10:58 -04:00
normalize-path dup parent-directory [
binary [ parse-tar ] with-file-reader
2009-04-15 20:31:02 -04:00
] with-directory ;