fix compiler errors in tar, can untar the linux kernel now
Doug Coleman
parent
c035f86ca2
commit
5337366643
|
|
@ -1,99 +1,92 @@
|
|||
USING: combinators io io.files io.streams.string kernel math
|
||||
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
|
||||
|
||||
: zero-checksum 256 ;
|
||||
: zero-checksum 256 ; inline
|
||||
: block-size 512 ; inline
|
||||
|
||||
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
|
||||
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 )
|
||||
[ "\0 " member? ] trim ;
|
||||
: 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 ;
|
||||
\ 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 ;
|
||||
|
||||
: header-checksum ( seq -- x )
|
||||
148 cut-slice 8 tail-slice
|
||||
[ sum ] bi@ + 256 + ;
|
||||
|
||||
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
|
||||
: 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
|
||||
] [
|
||||
drop
|
||||
>string write
|
||||
dup tar-header-size 512 - over set-tar-header-size
|
||||
(read-data-blocks)
|
||||
] if
|
||||
] if*
|
||||
] [
|
||||
drop
|
||||
] if* ;
|
||||
|
||||
: read-data-blocks ( tar-header out -- )
|
||||
[ (read-data-blocks) ] with-output-stream* ;
|
||||
] if ;
|
||||
|
||||
: parse-tar-header ( seq -- obj )
|
||||
[ header-checksum ] keep over zero-checksum = [
|
||||
2drop
|
||||
\ tar-header new
|
||||
0 over set-tar-header-size
|
||||
0 over set-tar-header-checksum
|
||||
0 >>size
|
||||
0 >>checksum
|
||||
] [
|
||||
[ read-tar-header ] with-string-reader
|
||||
[ tar-header-checksum = [
|
||||
\ checksum-error new throw
|
||||
] unless
|
||||
] keep
|
||||
[ checksum>> = [ checksum-error ] unless ] keep
|
||||
] if ;
|
||||
|
||||
ERROR: unknown-typeflag ch ;
|
||||
M: unknown-typeflag summary ( obj -- str )
|
||||
ch>> 1string
|
||||
"Unknown typeflag: " prepend ;
|
||||
ch>> 1string "Unknown typeflag: " prepend ;
|
||||
|
||||
: tar-append-path ( path -- newpath )
|
||||
: tar-prepend-path ( path -- newpath )
|
||||
base-dir get prepend-path ;
|
||||
|
||||
: read/write-blocks ( tar-header path -- )
|
||||
binary [ read-data-blocks ] with-file-writer ;
|
||||
|
||||
! Normal file
|
||||
: typeflag-0
|
||||
name>> tar-append-path binary <file-writer>
|
||||
[ read-data-blocks ] keep dispose ;
|
||||
: typeflag-0 ( header -- )
|
||||
dup name>> tar-prepend-path read/write-blocks ;
|
||||
|
||||
! Hard link
|
||||
: typeflag-1 ( header -- ) unknown-typeflag ;
|
||||
|
||||
! Symlink
|
||||
: typeflag-2 ( header -- ) unknown-typeflag ;
|
||||
: typeflag-2 ( header -- )
|
||||
[ name>> ] [ linkname>> ] bi
|
||||
[ make-link ] 2curry ignore-errors ;
|
||||
|
||||
! character special
|
||||
: typeflag-3 ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -103,7 +96,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
|
||||
! Directory
|
||||
: typeflag-5 ( header -- )
|
||||
tar-header-name tar-append-path make-directories ;
|
||||
name>> tar-prepend-path make-directories ;
|
||||
|
||||
! FIFO
|
||||
: typeflag-6 ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -118,7 +111,7 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
: typeflag-9 ( header -- ) unknown-typeflag ;
|
||||
|
||||
! Global POSIX header
|
||||
: typeflag-g ( header -- ) unknown-typeflag ;
|
||||
: typeflag-g ( header -- ) typeflag-0 ;
|
||||
|
||||
! Extended POSIX header
|
||||
: typeflag-x ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -140,10 +133,10 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
|
||||
! Long file name
|
||||
: typeflag-L ( header -- )
|
||||
<string-writer> [ read-data-blocks ] keep
|
||||
>string [ zero? ] right-trim filename set
|
||||
global [ "long filename: " write filename get . flush ] bind
|
||||
filename get tar-append-path make-directories ;
|
||||
drop ;
|
||||
! <string-writer> [ read-data-blocks ] keep
|
||||
! >string [ zero? ] right-trim filename set
|
||||
! filename get tar-prepend-path make-directories ;
|
||||
|
||||
! Multi volume continuation entry
|
||||
: typeflag-M ( header -- ) unknown-typeflag ;
|
||||
|
|
@ -161,56 +154,39 @@ M: unknown-typeflag summary ( obj -- str )
|
|||
: typeflag-X ( header -- ) unknown-typeflag ;
|
||||
|
||||
: (parse-tar) ( -- )
|
||||
512 read
|
||||
global [ dup hexdump. flush ] bind
|
||||
[
|
||||
block-size read dup length 512 = [
|
||||
parse-tar-header
|
||||
! global [ dup tar-header-name [ print flush ] when* ] bind
|
||||
dup tar-header-typeflag
|
||||
dup typeflag>>
|
||||
{
|
||||
{ 0 [ typeflag-0 ] }
|
||||
{ CHAR: 0 [ typeflag-0 ] }
|
||||
{ CHAR: 1 [ typeflag-1 ] }
|
||||
! { CHAR: 1 [ typeflag-1 ] }
|
||||
{ CHAR: 2 [ typeflag-2 ] }
|
||||
{ CHAR: 3 [ typeflag-3 ] }
|
||||
{ CHAR: 4 [ typeflag-4 ] }
|
||||
! { CHAR: 3 [ typeflag-3 ] }
|
||||
! { CHAR: 4 [ typeflag-4 ] }
|
||||
{ CHAR: 5 [ typeflag-5 ] }
|
||||
{ CHAR: 6 [ typeflag-6 ] }
|
||||
{ CHAR: 7 [ typeflag-7 ] }
|
||||
! { 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 ]
|
||||
} case
|
||||
! dup tar-header-size zero? [
|
||||
! out-stream get [ dispose ] when
|
||||
! out-stream off
|
||||
! 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* ;
|
||||
! { 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 -- obj )
|
||||
binary [
|
||||
"resource:tar-test" 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)
|
||||
] with-file-writer ;
|
||||
: parse-tar ( path -- )
|
||||
normalize-path dup parent-directory base-dir [
|
||||
binary [ (parse-tar) ] with-file-reader
|
||||
] with-variable ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue