2007-09-20 18:09:08 -04:00
|
|
|
USING: combinators io io.files io.streams.duplex
|
2008-01-31 13:21:49 -05:00
|
|
|
io.streams.string kernel math math.parser continuations
|
2008-02-02 01:29:47 -05:00
|
|
|
namespaces pack prettyprint sequences strings system
|
|
|
|
hexdump tools.interpreter ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: tar
|
|
|
|
|
|
|
|
: zero-checksum 256 ;
|
|
|
|
|
|
|
|
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
|
|
|
|
linkname magic version uname gname devmajor devminor prefix ;
|
|
|
|
|
|
|
|
: <tar-header> ( -- obj ) tar-header construct-empty ;
|
|
|
|
|
|
|
|
: tar-trim ( seq -- newseq )
|
|
|
|
[ "\0 " member? ] trim ;
|
|
|
|
|
|
|
|
: read-tar-header ( -- obj )
|
|
|
|
<tar-header>
|
|
|
|
100 read-c-string* over set-tar-header-name
|
|
|
|
8 read-c-string* tar-trim oct> over set-tar-header-mode
|
|
|
|
8 read-c-string* tar-trim oct> over set-tar-header-uid
|
|
|
|
8 read-c-string* tar-trim oct> over set-tar-header-gid
|
|
|
|
12 read-c-string* tar-trim oct> over set-tar-header-size
|
|
|
|
12 read-c-string* tar-trim oct> over set-tar-header-mtime
|
|
|
|
8 read-c-string* tar-trim oct> over set-tar-header-checksum
|
|
|
|
read1 over set-tar-header-typeflag
|
|
|
|
100 read-c-string* over set-tar-header-linkname
|
|
|
|
6 read over set-tar-header-magic
|
|
|
|
2 read over set-tar-header-version
|
|
|
|
32 read-c-string* over set-tar-header-uname
|
|
|
|
32 read-c-string* over set-tar-header-gname
|
|
|
|
8 read tar-trim oct> over set-tar-header-devmajor
|
|
|
|
8 read tar-trim oct> over set-tar-header-devminor
|
|
|
|
155 read-c-string* over set-tar-header-prefix ;
|
|
|
|
|
|
|
|
: header-checksum ( seq -- x )
|
2007-10-12 16:30:36 -04:00
|
|
|
148 cut-slice 8 tail-slice
|
2008-01-12 17:23:34 -05:00
|
|
|
[ sum ] 2apply + 256 + ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
TUPLE: checksum-error ;
|
|
|
|
TUPLE: malformed-block-error ;
|
|
|
|
|
|
|
|
SYMBOL: base-dir
|
|
|
|
SYMBOL: out-stream
|
|
|
|
SYMBOL: filename
|
|
|
|
|
|
|
|
: (read-data-blocks) ( tar-header -- )
|
|
|
|
512 read [
|
|
|
|
over tar-header-size dup 512 <= [
|
|
|
|
head-slice
|
|
|
|
>string write
|
|
|
|
drop
|
|
|
|
] [
|
|
|
|
drop
|
|
|
|
>string write
|
|
|
|
dup tar-header-size 512 - over set-tar-header-size
|
|
|
|
(read-data-blocks)
|
|
|
|
] if
|
|
|
|
] [
|
|
|
|
drop
|
|
|
|
] if* ;
|
|
|
|
|
|
|
|
: read-data-blocks ( tar-header out -- )
|
|
|
|
>r stdio get r> <duplex-stream> [
|
|
|
|
(read-data-blocks)
|
|
|
|
] with-stream* ;
|
|
|
|
|
|
|
|
: parse-tar-header ( seq -- obj )
|
|
|
|
[ header-checksum ] keep over zero-checksum = [
|
|
|
|
2drop
|
|
|
|
\ tar-header construct-empty
|
|
|
|
0 over set-tar-header-size
|
|
|
|
0 over set-tar-header-checksum
|
|
|
|
] [
|
|
|
|
[ read-tar-header ] string-in
|
|
|
|
[ tar-header-checksum = [
|
|
|
|
\ checksum-error construct-empty throw
|
|
|
|
] unless
|
|
|
|
] keep
|
|
|
|
] if ;
|
|
|
|
|
|
|
|
TUPLE: unknown-typeflag str ;
|
|
|
|
: <unknown-typeflag> ( ch -- obj )
|
|
|
|
1string \ unknown-typeflag construct-boa ;
|
|
|
|
|
|
|
|
TUPLE: unimplemented-typeflag header ;
|
|
|
|
: <unimplemented-typeflag> ( header -- obj )
|
|
|
|
global [ "Unimplemented typeflag: " print dup . flush ] bind
|
|
|
|
tar-header-typeflag
|
|
|
|
1string \ unimplemented-typeflag construct-boa ;
|
|
|
|
|
|
|
|
: tar-path+ ( path -- newpath )
|
|
|
|
base-dir get swap path+ ;
|
|
|
|
|
|
|
|
! Normal file
|
|
|
|
: typeflag-0
|
|
|
|
tar-header-name tar-path+ <file-writer>
|
2008-01-31 01:52:06 -05:00
|
|
|
[ read-data-blocks ] keep dispose ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
! Hard link
|
|
|
|
: typeflag-1 ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Symlink
|
|
|
|
: typeflag-2 ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! character special
|
|
|
|
: typeflag-3 ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Block special
|
|
|
|
: typeflag-4 ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Directory
|
|
|
|
: typeflag-5 ( header -- )
|
|
|
|
tar-header-name tar-path+ make-directories ;
|
|
|
|
|
|
|
|
! FIFO
|
|
|
|
: typeflag-6 ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Contiguous file
|
|
|
|
: typeflag-7 ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Global extended header
|
|
|
|
: typeflag-8 ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Extended header
|
|
|
|
: typeflag-9 ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Global POSIX header
|
|
|
|
: typeflag-g ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Extended POSIX header
|
|
|
|
: typeflag-x ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Solaris access control list
|
|
|
|
: typeflag-A ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! GNU dumpdir
|
|
|
|
: typeflag-D ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Solaris extended attribute file
|
|
|
|
: typeflag-E ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Inode metadata
|
|
|
|
: typeflag-I ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Long link name
|
|
|
|
: typeflag-K ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Long file name
|
|
|
|
: typeflag-L ( header -- )
|
|
|
|
<string-writer> [ read-data-blocks ] keep
|
2008-01-12 17:23:34 -05:00
|
|
|
>string [ zero? ] right-trim filename set
|
2007-09-20 18:09:08 -04:00
|
|
|
global [ "long filename: " write filename get . flush ] bind
|
|
|
|
filename get tar-path+ make-directories ;
|
|
|
|
|
|
|
|
! Multi volume continuation entry
|
|
|
|
: typeflag-M ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! GNU long file name
|
|
|
|
: typeflag-N ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Sparse file
|
|
|
|
: typeflag-S ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Volume header
|
|
|
|
: typeflag-V ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
! Vendor extended header type
|
|
|
|
: typeflag-X ( header -- )
|
|
|
|
<unimplemented-typeflag> throw ;
|
|
|
|
|
|
|
|
: (parse-tar) ( -- )
|
|
|
|
512 read
|
|
|
|
global [ dup hexdump. flush ] bind
|
|
|
|
[
|
|
|
|
parse-tar-header
|
|
|
|
! global [ dup tar-header-name [ print flush ] when* ] bind
|
|
|
|
dup tar-header-typeflag
|
|
|
|
{
|
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 ] }
|
|
|
|
{ CHAR: 2 [ typeflag-2 ] }
|
|
|
|
{ CHAR: 3 [ typeflag-3 ] }
|
|
|
|
{ CHAR: 4 [ typeflag-4 ] }
|
|
|
|
{ CHAR: 5 [ typeflag-5 ] }
|
|
|
|
{ CHAR: 6 [ typeflag-6 ] }
|
|
|
|
{ CHAR: 7 [ typeflag-7 ] }
|
|
|
|
{ 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 ] }
|
|
|
|
{ CHAR: L [ typeflag-L ] }
|
|
|
|
{ CHAR: M [ typeflag-M ] }
|
|
|
|
{ CHAR: N [ typeflag-N ] }
|
|
|
|
{ CHAR: S [ typeflag-S ] }
|
|
|
|
{ CHAR: V [ typeflag-V ] }
|
|
|
|
{ CHAR: X [ typeflag-X ] }
|
|
|
|
[ <unknown-typeflag> throw ]
|
|
|
|
} case
|
|
|
|
! dup tar-header-size zero? [
|
2008-01-31 01:52:06 -05:00
|
|
|
! out-stream get [ dispose ] when
|
2007-09-20 18:09:08 -04:00
|
|
|
! out-stream off
|
|
|
|
! drop
|
|
|
|
! ] [
|
|
|
|
! dup tar-header-name
|
|
|
|
! dup parent-dir base-dir swap path+
|
|
|
|
! global [ dup [ . flush ] when* ] bind
|
|
|
|
! make-directories <file-writer>
|
|
|
|
! out-stream set
|
|
|
|
! read-tar-blocks
|
|
|
|
! ] if
|
|
|
|
(parse-tar)
|
|
|
|
] when* ;
|
|
|
|
|
|
|
|
: parse-tar ( path -- obj )
|
2008-02-06 21:04:46 -05:00
|
|
|
[
|
2007-09-20 18:09:08 -04:00
|
|
|
"tar-test" resource-path base-dir set
|
|
|
|
global [ nl nl nl "Starting to parse .tar..." print flush ] bind
|
|
|
|
global [ "Expanding to: " write base-dir get . flush ] bind
|
|
|
|
(parse-tar)
|
2008-02-06 21:04:46 -05:00
|
|
|
] with-file-out ;
|