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

tar: cleanup stack effects, make read-data-blocks recursive.

db4 0.97
John Benediktsson 2014-11-02 11:38:49 -08:00
parent d31d836f86
commit eb3ca17974
1 changed files with 6 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
extra/tar/tar.factor
View File

@ -25,7 +25,7 @@ ERROR: checksum-error header ;
: read-c-string ( n -- str ) : read-c-string ( n -- str )
read [ zero? ] trim-tail "" like ; read [ zero? ] trim-tail "" like ;
: read-tar-header ( -- tar-header ) : read-tar-header ( -- header )
tar-header new tar-header new
100 read-c-string >>name 100 read-c-string >>name
8 read-c-string trim-string oct> >>mode 8 read-c-string trim-string oct> >>mode
@ -47,7 +47,7 @@ ERROR: checksum-error header ;
TYPED: checksum-header ( seq: byte-array -- n ) TYPED: checksum-header ( seq: byte-array -- n )
148 cut-slice 8 tail-slice [ 0 [ + ] reduce ] bi@ + 256 + >fixnum ; 148 cut-slice 8 tail-slice [ 0 [ + ] reduce ] bi@ + 256 + >fixnum ;
: read-data-blocks ( tar-header -- ) : read-data-blocks ( header -- )
dup size>> 0 > [ dup size>> 0 > [
block-size read [ block-size read [
over size>> dup block-size <= [ over size>> dup block-size <= [
@ -62,9 +62,9 @@ TYPED: checksum-header ( seq: byte-array -- n )
] if* ] if*
] [ ] [
drop drop
] if ; ] if ; inline recursive
: parse-tar-header ( seq -- obj ) : parse-tar-header ( seq -- header )
dup checksum-header dup zero-checksum = [ dup checksum-header dup zero-checksum = [
2drop 2drop
tar-header new tar-header new
@ -79,10 +79,10 @@ TYPED: checksum-header ( seq: byte-array -- n )
ERROR: unknown-typeflag ch ; ERROR: unknown-typeflag ch ;
M: unknown-typeflag summary ( obj -- str ) M: unknown-typeflag summary
ch>> [ "Unknown typeflag: " ] dip prefix ; ch>> [ "Unknown typeflag: " ] dip prefix ;
: read/write-blocks ( tar-header path -- ) : read/write-blocks ( header path -- )
binary [ read-data-blocks ] with-file-writer ; binary [ read-data-blocks ] with-file-writer ;
: prepend-current-directory ( path -- path' ) : prepend-current-directory ( path -- path' )