From 5337366643fab269ae264b390c2dae96efdbc2c9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 May 2008 21:11:27 -0500 Subject: [PATCH] fix compiler errors in tar, can untar the linux kernel now --- extra/tar/tar.factor | 190 +++++++++++++++++++------------------------ 1 file changed, 83 insertions(+), 107 deletions(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index b5d01b6ed2..644cf9aa72 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -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 ; -: ( -- 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 ) - - 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 - [ 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 -- ) - [ 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 ; + ! [ 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 - ! 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 ;