-USING: combinators io io.files io.files.links io.directories
-io.pathnames io.streams.string kernel math math.parser
-continuations namespaces pack prettyprint sequences strings
-system tools.hexdump io.encodings.binary summary accessors
-io.backend byte-arrays ;
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays combinators io io.backend
+io.directories io.encodings.binary io.files io.files.links
+io.pathnames io.streams.byte-array io.streams.string kernel
+math math.parser namespaces sequences summary typed ;
IN: tar
-: zero-checksum 256 ; inline
-: block-size 512 ; inline
+CONSTANT: zero-checksum 256
+CONSTANT: block-size 512
+
+SYMBOL: to-link
+
+: save-link ( link -- )
+ to-link get push ;
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
-ERROR: checksum-error ;
-
-SYMBOLS: base-dir filename ;
-
-: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
-
-: read-c-string* ( n -- str/f )
- read [ zero? ] trim-right [ f ] when-empty ;
-
-: read-tar-header ( -- obj )
- \ 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 + ;
-
-: read-data-blocks ( tar-header -- )
+
+ERROR: checksum-error header ;
+
+: trim-string ( seq -- newseq ) [ "\0 " member? ] trim-tail ;
+
+: read-c-string ( n -- str )
+ read [ zero? ] trim-tail "" like ;
+
+: read-tar-header ( -- header )
+ tar-header new
+ 100 read-c-string >>name
+ 8 read-c-string trim-string oct> >>mode
+ 8 read-c-string trim-string oct> >>uid
+ 8 read-c-string trim-string oct> >>gid
+ 12 read-c-string trim-string oct> >>size
+ 12 read-c-string trim-string oct> >>mtime
+ 8 read-c-string trim-string 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 trim-string oct> >>devmajor
+ 8 read trim-string oct> >>devminor
+ 155 read-c-string >>prefix ;
+
+TYPED: checksum-header ( seq: byte-array -- n )
+ 148 cut-slice 8 tail-slice [ 0 [ + ] reduce ] bi@ + 256 + >fixnum ;
+
+: read-data-blocks ( header -- )
dup size>> 0 > [
block-size read [
over size>> dup block-size <= [
- head-slice >byte-array write drop
+ head write drop
] [
drop write
[ block-size - ] change-size
] if*
] [
drop
- ] if ;
+ ] if ; inline recursive
-: parse-tar-header ( seq -- obj )
- [ header-checksum ] keep over zero-checksum = [
+: parse-tar-header ( seq -- header )
+ dup checksum-header dup zero-checksum = [
2drop
- \ tar-header new
+ tar-header new
0 >>size
0 >>checksum
] [
- [ read-tar-header ] with-string-reader
- [ checksum>> = [ checksum-error ] unless ] keep
+ [
+ binary [ read-tar-header ] with-byte-reader
+ dup checksum>>
+ ] dip = [ checksum-error ] unless
] if ;
ERROR: unknown-typeflag ch ;
-M: unknown-typeflag summary ( obj -- str )
- ch>> 1string "Unknown typeflag: " prepend ;
-: tar-prepend-path ( path -- newpath )
- base-dir get prepend-path ;
+M: unknown-typeflag summary
+ ch>> [ "Unknown typeflag: " ] dip prefix ;
-: read/write-blocks ( tar-header path -- )
+: read/write-blocks ( header path -- )
binary [ read-data-blocks ] with-file-writer ;
! Normal file
: typeflag-0 ( header -- )
- dup name>> tar-prepend-path read/write-blocks ;
+ dup name>> read/write-blocks ;
+
+TUPLE: hard-link linkname name ;
+C: <hard-link> hard-link
-! Hard link
-: typeflag-1 ( header -- ) unknown-typeflag ;
+TUPLE: symbolic-link linkname name ;
+C: <symbolic-link> symbolic-link
-! Symlink
+! Hard link, don't call normalize-path
+: typeflag-1 ( header -- )
+ [ linkname>> ] [ name>> ] bi <hard-link> save-link ;
+
+! Symlink, don't call normalize-path
: typeflag-2 ( header -- )
- [ name>> ] [ linkname>> ] bi
- [ make-link ] 2curry ignore-errors ;
+ [ linkname>> ] [ name>> ] bi <symbolic-link> save-link ;
! character special
: typeflag-3 ( header -- ) unknown-typeflag ;
! Directory
: typeflag-5 ( header -- )
- name>> tar-prepend-path make-directories ;
+ name>> make-directories ;
! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ;
: typeflag-9 ( header -- ) unknown-typeflag ;
! Global POSIX header
-: typeflag-g ( header -- ) typeflag-0 ;
+: typeflag-g ( header -- )
+ ! Read something like: 52 comment=9f2a940965286754f3a34d5737c3097c05db8725
+ ! and drop it
+ [ read-data-blocks ] with-string-writer drop ;
! Extended POSIX header
: typeflag-x ( header -- ) unknown-typeflag ;
! Long file name
: typeflag-L ( header -- )
- drop ;
- ! <string-writer> [ read-data-blocks ] keep
- ! >string [ zero? ] trim-right filename set
- ! filename get tar-prepend-path make-directories ;
+ drop
+ ;
+ ! [ read-data-blocks ] with-string-writer
+ ! [ zero? ] trim-tail filename set
+ ! filename get make-directories ;
! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ;
! Vendor extended header type
: typeflag-X ( header -- ) unknown-typeflag ;
-: (parse-tar) ( -- )
- block-size read dup length 512 = [
+: parse-tar ( -- )
+ block-size read dup length block-size = [
parse-tar-header
dup typeflag>>
{
! { CHAR: E [ typeflag-E ] }
! { CHAR: I [ typeflag-I ] }
! { CHAR: K [ typeflag-K ] }
- ! { CHAR: L [ typeflag-L ] }
+ { 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)
+ } case parse-tar
] [
drop
] if ;
-: parse-tar ( path -- )
- normalize-path dup parent-directory base-dir [
- binary [ (parse-tar) ] with-file-reader
- ] with-variable ;
+GENERIC: do-link ( object -- )
+
+M: hard-link do-link
+ [ linkname>> ] [ name>> ] bi make-hard-link ;
+
+M: symbolic-link do-link
+ [ linkname>> ] [ name>> ] bi make-link ;
+
+! FIXME: linux tar calls unlinkat and makelinkat
+: make-links ( -- )
+ to-link get [
+ [ name>> ?delete-file ] [ do-link ] bi
+ ] each ;
+
+: untar ( path -- )
+ normalize-path dup parent-directory [
+ V{ } clone to-link [
+ binary [ parse-tar ] with-file-reader
+ make-links
+ ] with-variable
+ ] with-directory ;
projects / factor.git / blobdiff