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

refactor tar a bit

db4
Doug Coleman 2008-04-11 12:53:46 -05:00
parent bced4022e5
commit f61d5a52d1
1 changed files with 28 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

81
extra/tar/tar.factor
View File

@ -1,7 +1,7 @@
USING: combinators io io.files io.streams.duplex USING: combinators io io.files io.streams.duplex
io.streams.string kernel math math.parser continuations io.streams.string kernel math math.parser continuations
namespaces pack prettyprint sequences strings system namespaces pack prettyprint sequences strings system
hexdump io.encodings.binary ; hexdump io.encodings.binary inspector accessors ;
IN: tar IN: tar
: zero-checksum 256 ; : zero-checksum 256 ;
@ -79,87 +79,67 @@ SYMBOL: filename
] keep ] keep
] if ; ] if ;
TUPLE: unknown-typeflag str ; ERROR: unknown-typeflag ch ;
: <unknown-typeflag> ( ch -- obj ) M: unknown-typeflag summary ( obj -- str )
1string \ unknown-typeflag construct-boa ; ch>> 1string
"Unknown typeflag: " prepend ;
TUPLE: unimplemented-typeflag header ;
: <unimplemented-typeflag> ( header -- obj )
global [ "Unimplemented typeflag: " print dup . flush ] bind
tar-header-typeflag
1string \ unimplemented-typeflag construct-boa ;
: tar-append-path ( path -- newpath ) : tar-append-path ( path -- newpath )
base-dir get prepend-path ; base-dir get prepend-path ;
! Normal file ! Normal file
: typeflag-0 : typeflag-0
tar-header-name tar-append-path binary <file-writer> name>> tar-append-path binary <file-writer>
[ read-data-blocks ] keep dispose ; [ read-data-blocks ] keep dispose ;
! Hard link ! Hard link
: typeflag-1 ( header -- ) : typeflag-1 ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Symlink ! Symlink
: typeflag-2 ( header -- ) : typeflag-2 ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! character special ! character special
: typeflag-3 ( header -- ) : typeflag-3 ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Block special ! Block special
: typeflag-4 ( header -- ) : typeflag-4 ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Directory ! Directory
: typeflag-5 ( header -- ) : typeflag-5 ( header -- )
tar-header-name tar-append-path make-directories ; tar-header-name tar-append-path make-directories ;
! FIFO ! FIFO
: typeflag-6 ( header -- ) : typeflag-6 ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Contiguous file ! Contiguous file
: typeflag-7 ( header -- ) : typeflag-7 ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Global extended header ! Global extended header
: typeflag-8 ( header -- ) : typeflag-8 ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Extended header ! Extended header
: typeflag-9 ( header -- ) : typeflag-9 ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Global POSIX header ! Global POSIX header
: typeflag-g ( header -- ) : typeflag-g ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Extended POSIX header ! Extended POSIX header
: typeflag-x ( header -- ) : typeflag-x ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Solaris access control list ! Solaris access control list
: typeflag-A ( header -- ) : typeflag-A ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! GNU dumpdir ! GNU dumpdir
: typeflag-D ( header -- ) : typeflag-D ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Solaris extended attribute file ! Solaris extended attribute file
: typeflag-E ( header -- ) : typeflag-E ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Inode metadata ! Inode metadata
: typeflag-I ( header -- ) : typeflag-I ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Long link name ! Long link name
: typeflag-K ( header -- ) : typeflag-K ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Long file name ! Long file name
: typeflag-L ( header -- ) : typeflag-L ( header -- )
@ -169,24 +149,19 @@ TUPLE: unimplemented-typeflag header ;
filename get tar-append-path make-directories ; filename get tar-append-path make-directories ;
! Multi volume continuation entry ! Multi volume continuation entry
: typeflag-M ( header -- ) : typeflag-M ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! GNU long file name ! GNU long file name
: typeflag-N ( header -- ) : typeflag-N ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Sparse file ! Sparse file
: typeflag-S ( header -- ) : typeflag-S ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Volume header ! Volume header
: typeflag-V ( header -- ) : typeflag-V ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
! Vendor extended header type ! Vendor extended header type
: typeflag-X ( header -- ) : typeflag-X ( header -- ) unknown-typeflag ;
<unimplemented-typeflag> throw ;
: (parse-tar) ( -- ) : (parse-tar) ( -- )
512 read 512 read
@ -218,7 +193,7 @@ TUPLE: unimplemented-typeflag header ;
{ CHAR: S [ typeflag-S ] } { CHAR: S [ typeflag-S ] }
{ CHAR: V [ typeflag-V ] } { CHAR: V [ typeflag-V ] }
{ CHAR: X [ typeflag-X ] } { CHAR: X [ typeflag-X ] }
[ <unknown-typeflag> throw ] [ unknown-typeflag ]
} case } case
! dup tar-header-size zero? [ ! dup tar-header-size zero? [
! out-stream get [ dispose ] when ! out-stream get [ dispose ] when
@ -237,7 +212,7 @@ TUPLE: unimplemented-typeflag header ;
: parse-tar ( path -- obj ) : parse-tar ( path -- obj )
binary [ binary [
"tar-test" resource-path base-dir set "resource:tar-test" base-dir set
global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ nl nl nl "Starting to parse .tar..." print flush ] bind
global [ "Expanding to: " write base-dir get . flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind
(parse-tar) (parse-tar)