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

fix compiler errors in tar, can untar the linux kernel now

db4
Doug Coleman 2008-05-09 21:11:27 -05:00
parent c035f86ca2
commit 5337366643
1 changed files with 83 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

190
extra/tar/tar.factor
View File

@ -1,99 +1,92 @@
USING: combinators io io.files io.streams.string kernel math USING: combinators io io.files io.streams.string kernel math
math.parser continuations namespaces pack prettyprint sequences math.parser continuations namespaces pack prettyprint sequences
strings system hexdump io.encodings.binary inspector accessors ; strings system hexdump io.encodings.binary inspector accessors
io.backend symbols byte-arrays ;
IN: tar IN: tar
: zero-checksum 256 ; : zero-checksum 256 ; inline
: block-size 512 ; inline
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 ;
: <tar-header> ( -- obj ) tar-header new ; SYMBOLS: base-dir filename ;
: tar-trim ( seq -- newseq ) : tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
[ "\0 " member? ] trim ;
: read-tar-header ( -- obj ) : read-tar-header ( -- obj )
<tar-header> \ tar-header new
100 read-c-string* over set-tar-header-name 100 read-c-string* >>name
8 read-c-string* tar-trim oct> over set-tar-header-mode 8 read-c-string* tar-trim oct> >>mode
8 read-c-string* tar-trim oct> over set-tar-header-uid 8 read-c-string* tar-trim oct> >>uid
8 read-c-string* tar-trim oct> over set-tar-header-gid 8 read-c-string* tar-trim oct> >>gid
12 read-c-string* tar-trim oct> over set-tar-header-size 12 read-c-string* tar-trim oct> >>size
12 read-c-string* tar-trim oct> over set-tar-header-mtime 12 read-c-string* tar-trim oct> >>mtime
8 read-c-string* tar-trim oct> over set-tar-header-checksum 8 read-c-string* tar-trim oct> >>checksum
read1 over set-tar-header-typeflag read1 >>typeflag
100 read-c-string* over set-tar-header-linkname 100 read-c-string* >>linkname
6 read over set-tar-header-magic 6 read >>magic
2 read over set-tar-header-version 2 read >>version
32 read-c-string* over set-tar-header-uname 32 read-c-string* >>uname
32 read-c-string* over set-tar-header-gname 32 read-c-string* >>gname
8 read tar-trim oct> over set-tar-header-devmajor 8 read tar-trim oct> >>devmajor
8 read tar-trim oct> over set-tar-header-devminor 8 read tar-trim oct> >>devminor
155 read-c-string* over set-tar-header-prefix ; 155 read-c-string* >>prefix ;
: header-checksum ( seq -- x ) : header-checksum ( seq -- x )
148 cut-slice 8 tail-slice 148 cut-slice 8 tail-slice
[ sum ] bi@ + 256 + ; [ sum ] bi@ + 256 + ;
TUPLE: checksum-error ; : read-data-blocks ( tar-header -- )
TUPLE: malformed-block-error ; dup size>> 0 > [
block-size read [
SYMBOL: base-dir over size>> dup block-size <= [
SYMBOL: out-stream head-slice >byte-array write drop
SYMBOL: filename ] [
drop write
: (read-data-blocks) ( tar-header -- ) [ block-size - ] change-size
512 read [ read-data-blocks
over tar-header-size dup 512 <= [ ] if
head-slice
>string write
drop
] [ ] [
drop drop
>string write ] if*
dup tar-header-size 512 - over set-tar-header-size
(read-data-blocks)
] if
] [ ] [
drop drop
] if* ; ] if ;
: read-data-blocks ( tar-header out -- )
[ (read-data-blocks) ] with-output-stream* ;
: parse-tar-header ( seq -- obj ) : parse-tar-header ( seq -- obj )
[ header-checksum ] keep over zero-checksum = [ [ header-checksum ] keep over zero-checksum = [
2drop 2drop
\ tar-header new \ tar-header new
0 over set-tar-header-size 0 >>size
0 over set-tar-header-checksum 0 >>checksum
] [ ] [
[ read-tar-header ] with-string-reader [ read-tar-header ] with-string-reader
[ tar-header-checksum = [ [ checksum>> = [ checksum-error ] unless ] keep
\ checksum-error new throw
] unless
] keep
] if ; ] if ;
ERROR: unknown-typeflag ch ; ERROR: unknown-typeflag ch ;
M: unknown-typeflag summary ( obj -- str ) M: unknown-typeflag summary ( obj -- str )
ch>> 1string ch>> 1string "Unknown typeflag: " prepend ;
"Unknown typeflag: " prepend ;
: tar-append-path ( path -- newpath ) : tar-prepend-path ( path -- newpath )
base-dir get prepend-path ; base-dir get prepend-path ;
: read/write-blocks ( tar-header path -- )
binary [ read-data-blocks ] with-file-writer ;
! Normal file ! Normal file
: typeflag-0 : typeflag-0 ( header -- )
name>> tar-append-path binary <file-writer> dup name>> tar-prepend-path read/write-blocks ;
[ read-data-blocks ] keep dispose ;
! Hard link ! Hard link
: typeflag-1 ( header -- ) unknown-typeflag ; : typeflag-1 ( header -- ) unknown-typeflag ;
! Symlink ! Symlink
: typeflag-2 ( header -- ) unknown-typeflag ; : typeflag-2 ( header -- )
[ name>> ] [ linkname>> ] bi
[ make-link ] 2curry ignore-errors ;
! character special ! character special
: typeflag-3 ( header -- ) unknown-typeflag ; : typeflag-3 ( header -- ) unknown-typeflag ;
@ -103,7 +96,7 @@ M: unknown-typeflag summary ( obj -- str )
! Directory ! Directory
: typeflag-5 ( header -- ) : typeflag-5 ( header -- )
tar-header-name tar-append-path make-directories ; name>> tar-prepend-path make-directories ;
! FIFO ! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ; : typeflag-6 ( header -- ) unknown-typeflag ;
@ -118,7 +111,7 @@ M: unknown-typeflag summary ( obj -- str )
: typeflag-9 ( header -- ) unknown-typeflag ; : typeflag-9 ( header -- ) unknown-typeflag ;
! Global POSIX header ! Global POSIX header
: typeflag-g ( header -- ) unknown-typeflag ; : typeflag-g ( header -- ) typeflag-0 ;
! Extended POSIX header ! Extended POSIX header
: typeflag-x ( header -- ) unknown-typeflag ; : typeflag-x ( header -- ) unknown-typeflag ;
@ -140,10 +133,10 @@ M: unknown-typeflag summary ( obj -- str )
! Long file name ! Long file name
: typeflag-L ( header -- ) : typeflag-L ( header -- )
<string-writer> [ read-data-blocks ] keep drop ;
>string [ zero? ] right-trim filename set ! <string-writer> [ read-data-blocks ] keep
global [ "long filename: " write filename get . flush ] bind ! >string [ zero? ] right-trim filename set
filename get tar-append-path make-directories ; ! filename get tar-prepend-path make-directories ;
! Multi volume continuation entry ! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ; : typeflag-M ( header -- ) unknown-typeflag ;
@ -161,56 +154,39 @@ M: unknown-typeflag summary ( obj -- str )
: typeflag-X ( header -- ) unknown-typeflag ; : typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- ) : (parse-tar) ( -- )
512 read block-size read dup length 512 = [
global [ dup hexdump. flush ] bind
[
parse-tar-header parse-tar-header
! global [ dup tar-header-name [ print flush ] when* ] bind dup typeflag>>
dup tar-header-typeflag
{ {
{ 0 [ typeflag-0 ] } { 0 [ typeflag-0 ] }
{ CHAR: 0 [ typeflag-0 ] } { CHAR: 0 [ typeflag-0 ] }
{ CHAR: 1 [ typeflag-1 ] } ! { CHAR: 1 [ typeflag-1 ] }
{ CHAR: 2 [ typeflag-2 ] } { CHAR: 2 [ typeflag-2 ] }
{ CHAR: 3 [ typeflag-3 ] } ! { CHAR: 3 [ typeflag-3 ] }
{ CHAR: 4 [ typeflag-4 ] } ! { CHAR: 4 [ typeflag-4 ] }
{ CHAR: 5 [ typeflag-5 ] } { CHAR: 5 [ typeflag-5 ] }
{ CHAR: 6 [ typeflag-6 ] } ! { CHAR: 6 [ typeflag-6 ] }
{ CHAR: 7 [ typeflag-7 ] } ! { CHAR: 7 [ typeflag-7 ] }
{ CHAR: g [ typeflag-g ] } { CHAR: g [ typeflag-g ] }
{ CHAR: x [ typeflag-x ] } ! { CHAR: x [ typeflag-x ] }
{ CHAR: A [ typeflag-A ] } ! { CHAR: A [ typeflag-A ] }
{ CHAR: D [ typeflag-D ] } ! { CHAR: D [ typeflag-D ] }
{ CHAR: E [ typeflag-E ] } ! { CHAR: E [ typeflag-E ] }
{ CHAR: I [ typeflag-I ] } ! { CHAR: I [ typeflag-I ] }
{ CHAR: K [ typeflag-K ] } ! { CHAR: K [ typeflag-K ] }
{ CHAR: L [ typeflag-L ] } ! { CHAR: L [ typeflag-L ] }
{ CHAR: M [ typeflag-M ] } ! { CHAR: M [ typeflag-M ] }
{ CHAR: N [ typeflag-N ] } ! { CHAR: N [ typeflag-N ] }
{ 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 ] { f [ drop ] }
} case } case (parse-tar)
! dup tar-header-size zero? [ ] [
! out-stream get [ dispose ] when drop
! out-stream off ] if ;
! drop
! ] [
! dup tar-header-name
! dup parent-dir base-dir prepend-path
! global [ dup [ . flush ] when* ] bind
! make-directories <file-writer>
! out-stream set
! read-tar-blocks
! ] if
(parse-tar)
] when* ;
: parse-tar ( path -- obj ) : parse-tar ( path -- )
binary [ normalize-path dup parent-directory base-dir [
"resource:tar-test" base-dir set binary [ (parse-tar) ] with-file-reader
global [ nl nl nl "Starting to parse .tar..." print flush ] bind ] with-variable ;
global [ "Expanding to: " write base-dir get . flush ] bind
(parse-tar)
] with-file-writer ;