1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors byte-arrays combinators io io.backend
4 io.directories io.encodings.binary io.files io.files.links
5 io.pathnames io.streams.byte-array io.streams.string kernel
6 math math.parser namespaces sequences strings summary
10 CONSTANT: zero-checksum 256
11 CONSTANT: block-size 512
15 : save-link ( link -- )
18 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
19 linkname magic version uname gname devmajor devminor prefix ;
21 ERROR: checksum-error header ;
23 : trim-string ( seq -- newseq ) [ "\0 " member? ] trim-tail ;
25 : read-c-string ( n -- str )
26 read [ zero? ] trim-tail "" like ;
28 : read-tar-header ( -- header )
30 100 read-c-string >>name
31 8 read-c-string trim-string oct> >>mode
32 8 read-c-string trim-string oct> >>uid
33 8 read-c-string trim-string oct> >>gid
34 12 read-c-string trim-string oct> >>size
35 12 read-c-string trim-string oct> >>mtime
36 8 read-c-string trim-string oct> >>checksum
38 100 read-c-string >>linkname
41 32 read-c-string >>uname
42 32 read-c-string >>gname
43 8 read trim-string oct> >>devmajor
44 8 read trim-string oct> >>devminor
45 155 read-c-string >>prefix ;
47 TYPED: checksum-header ( seq: byte-array -- n )
48 148 cut-slice 8 tail-slice [ 0 [ + ] reduce ] bi@ + 256 + >fixnum ;
50 : read-data-blocks ( header -- )
53 over size>> dup block-size <= [
57 [ block-size - ] change-size
65 ] if ; inline recursive
67 : parse-tar-header ( seq -- header )
68 dup checksum-header dup zero-checksum = [
75 binary [ read-tar-header ] with-byte-reader
77 ] dip = [ throw-checksum-error ] unless
80 ERROR: unknown-typeflag ch ;
82 M: unknown-typeflag summary
83 ch>> [ "Unknown typeflag: " ] dip prefix ;
85 : read/write-blocks ( header path -- )
86 binary [ read-data-blocks ] with-file-writer ;
88 : prepend-current-directory ( path -- path' )
89 current-directory get prepend-path ;
92 : typeflag-0 ( header -- )
93 dup name>> prepend-current-directory read/write-blocks ;
95 TUPLE: hard-link linkname name ;
96 C: <hard-link> hard-link
98 TUPLE: symbolic-link linkname name ;
99 C: <symbolic-link> symbolic-link
101 ! Hard link, don't call normalize-path
102 : typeflag-1 ( header -- )
103 [ linkname>> ] [ name>> ] bi <hard-link> save-link ;
105 ! Symlink, don't call normalize-path
106 : typeflag-2 ( header -- )
107 [ linkname>> ] [ name>> ] bi <symbolic-link> save-link ;
110 : typeflag-3 ( header -- ) unknown-typeflag ;
113 : typeflag-4 ( header -- ) unknown-typeflag ;
116 : typeflag-5 ( header -- )
117 name>> prepend-current-directory make-directories ;
120 : typeflag-6 ( header -- ) unknown-typeflag ;
123 : typeflag-7 ( header -- ) unknown-typeflag ;
125 ! Global extended header
126 : typeflag-8 ( header -- ) unknown-typeflag ;
129 : typeflag-9 ( header -- ) unknown-typeflag ;
131 ! Global POSIX header
132 : typeflag-g ( header -- )
133 ! Read something like: 52 comment=9f2a940965286754f3a34d5737c3097c05db8725
135 [ read-data-blocks ] with-string-writer drop ;
137 ! Extended POSIX header
138 : typeflag-x ( header -- ) unknown-typeflag ;
140 ! Solaris access control list
141 : typeflag-A ( header -- ) unknown-typeflag ;
144 : typeflag-D ( header -- ) unknown-typeflag ;
146 ! Solaris extended attribute file
147 : typeflag-E ( header -- ) unknown-typeflag ;
150 : typeflag-I ( header -- ) unknown-typeflag ;
153 : typeflag-K ( header -- ) unknown-typeflag ;
156 : typeflag-L ( header -- )
159 ! [ read-data-blocks ] with-string-writer
160 ! [ zero? ] trim-tail filename set
161 ! filename get prepend-current-directory make-directories ;
163 ! Multi volume continuation entry
164 : typeflag-M ( header -- ) unknown-typeflag ;
167 : typeflag-N ( header -- ) unknown-typeflag ;
170 : typeflag-S ( header -- ) unknown-typeflag ;
173 : typeflag-V ( header -- ) unknown-typeflag ;
175 ! Vendor extended header type
176 : typeflag-X ( header -- ) unknown-typeflag ;
179 block-size read dup length block-size = [
184 { CHAR: 0 [ typeflag-0 ] }
185 ! { CHAR: 1 [ typeflag-1 ] }
186 { CHAR: 2 [ typeflag-2 ] }
187 ! { CHAR: 3 [ typeflag-3 ] }
188 ! { CHAR: 4 [ typeflag-4 ] }
189 { CHAR: 5 [ typeflag-5 ] }
190 ! { CHAR: 6 [ typeflag-6 ] }
191 ! { CHAR: 7 [ typeflag-7 ] }
192 { CHAR: g [ typeflag-g ] }
193 ! { CHAR: x [ typeflag-x ] }
194 ! { CHAR: A [ typeflag-A ] }
195 ! { CHAR: D [ typeflag-D ] }
196 ! { CHAR: E [ typeflag-E ] }
197 ! { CHAR: I [ typeflag-I ] }
198 ! { CHAR: K [ typeflag-K ] }
199 { CHAR: L [ typeflag-L ] }
200 ! { CHAR: M [ typeflag-M ] }
201 ! { CHAR: N [ typeflag-N ] }
202 ! { CHAR: S [ typeflag-S ] }
203 ! { CHAR: V [ typeflag-V ] }
204 ! { CHAR: X [ typeflag-X ] }
211 GENERIC: do-link ( object -- )
215 [ name>> prepend-current-directory ] bi make-hard-link ;
217 M: symbolic-link do-link
219 [ name>> prepend-current-directory ] bi make-link ;
221 ! FIXME: linux tar calls unlinkat and makelinkat
224 [ name>> ?delete-file ] [ do-link ] bi
228 normalize-path dup parent-directory [
230 binary [ parse-tar ] with-file-reader