1 USING: combinators io io.files io.streams.string kernel math
2 math.parser continuations namespaces pack prettyprint sequences
3 strings system hexdump io.encodings.binary inspector accessors
4 io.backend symbols byte-arrays ;
7 : zero-checksum 256 ; inline
8 : block-size 512 ; inline
10 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
11 linkname magic version uname gname devmajor devminor prefix ;
12 ERROR: checksum-error ;
14 SYMBOLS: base-dir filename ;
16 : tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
18 : read-tar-header ( -- obj )
20 100 read-c-string* >>name
21 8 read-c-string* tar-trim oct> >>mode
22 8 read-c-string* tar-trim oct> >>uid
23 8 read-c-string* tar-trim oct> >>gid
24 12 read-c-string* tar-trim oct> >>size
25 12 read-c-string* tar-trim oct> >>mtime
26 8 read-c-string* tar-trim oct> >>checksum
28 100 read-c-string* >>linkname
31 32 read-c-string* >>uname
32 32 read-c-string* >>gname
33 8 read tar-trim oct> >>devmajor
34 8 read tar-trim oct> >>devminor
35 155 read-c-string* >>prefix ;
37 : header-checksum ( seq -- x )
38 148 cut-slice 8 tail-slice
41 : read-data-blocks ( tar-header -- )
44 over size>> dup block-size <= [
45 head-slice >byte-array write drop
48 [ block-size - ] change-size
58 : parse-tar-header ( seq -- obj )
59 [ header-checksum ] keep over zero-checksum = [
65 [ read-tar-header ] with-string-reader
66 [ checksum>> = [ checksum-error ] unless ] keep
69 ERROR: unknown-typeflag ch ;
70 M: unknown-typeflag summary ( obj -- str )
71 ch>> 1string "Unknown typeflag: " prepend ;
73 : tar-prepend-path ( path -- newpath )
74 base-dir get prepend-path ;
76 : read/write-blocks ( tar-header path -- )
77 binary [ read-data-blocks ] with-file-writer ;
80 : typeflag-0 ( header -- )
81 dup name>> tar-prepend-path read/write-blocks ;
84 : typeflag-1 ( header -- ) unknown-typeflag ;
87 : typeflag-2 ( header -- )
88 [ name>> ] [ linkname>> ] bi
89 [ make-link ] 2curry ignore-errors ;
92 : typeflag-3 ( header -- ) unknown-typeflag ;
95 : typeflag-4 ( header -- ) unknown-typeflag ;
98 : typeflag-5 ( header -- )
99 name>> tar-prepend-path make-directories ;
102 : typeflag-6 ( header -- ) unknown-typeflag ;
105 : typeflag-7 ( header -- ) unknown-typeflag ;
107 ! Global extended header
108 : typeflag-8 ( header -- ) unknown-typeflag ;
111 : typeflag-9 ( header -- ) unknown-typeflag ;
113 ! Global POSIX header
114 : typeflag-g ( header -- ) typeflag-0 ;
116 ! Extended POSIX header
117 : typeflag-x ( header -- ) unknown-typeflag ;
119 ! Solaris access control list
120 : typeflag-A ( header -- ) unknown-typeflag ;
123 : typeflag-D ( header -- ) unknown-typeflag ;
125 ! Solaris extended attribute file
126 : typeflag-E ( header -- ) unknown-typeflag ;
129 : typeflag-I ( header -- ) unknown-typeflag ;
132 : typeflag-K ( header -- ) unknown-typeflag ;
135 : typeflag-L ( header -- )
137 ! <string-writer> [ read-data-blocks ] keep
138 ! >string [ zero? ] right-trim filename set
139 ! filename get tar-prepend-path make-directories ;
141 ! Multi volume continuation entry
142 : typeflag-M ( header -- ) unknown-typeflag ;
145 : typeflag-N ( header -- ) unknown-typeflag ;
148 : typeflag-S ( header -- ) unknown-typeflag ;
151 : typeflag-V ( header -- ) unknown-typeflag ;
153 ! Vendor extended header type
154 : typeflag-X ( header -- ) unknown-typeflag ;
157 block-size read dup length 512 = [
162 { CHAR: 0 [ typeflag-0 ] }
163 ! { CHAR: 1 [ typeflag-1 ] }
164 { CHAR: 2 [ typeflag-2 ] }
165 ! { CHAR: 3 [ typeflag-3 ] }
166 ! { CHAR: 4 [ typeflag-4 ] }
167 { CHAR: 5 [ typeflag-5 ] }
168 ! { CHAR: 6 [ typeflag-6 ] }
169 ! { CHAR: 7 [ typeflag-7 ] }
170 { CHAR: g [ typeflag-g ] }
171 ! { CHAR: x [ typeflag-x ] }
172 ! { CHAR: A [ typeflag-A ] }
173 ! { CHAR: D [ typeflag-D ] }
174 ! { CHAR: E [ typeflag-E ] }
175 ! { CHAR: I [ typeflag-I ] }
176 ! { CHAR: K [ typeflag-K ] }
177 ! { CHAR: L [ typeflag-L ] }
178 ! { CHAR: M [ typeflag-M ] }
179 ! { CHAR: N [ typeflag-N ] }
180 ! { CHAR: S [ typeflag-S ] }
181 ! { CHAR: V [ typeflag-V ] }
182 ! { CHAR: X [ typeflag-X ] }
189 : parse-tar ( path -- )
190 normalize-path dup parent-directory base-dir [
191 binary [ (parse-tar) ] with-file-reader