1 USING: combinators io io.files io.files.links io.directories
2 io.pathnames io.streams.string kernel math math.parser
3 continuations namespaces pack prettyprint sequences strings
4 system tools.hexdump io.encodings.binary summary accessors
5 io.backend symbols byte-arrays ;
8 : zero-checksum 256 ; inline
9 : block-size 512 ; inline
11 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
12 linkname magic version uname gname devmajor devminor prefix ;
13 ERROR: checksum-error ;
15 SYMBOLS: base-dir filename ;
17 : tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
19 : read-tar-header ( -- obj )
21 100 read-c-string* >>name
22 8 read-c-string* tar-trim oct> >>mode
23 8 read-c-string* tar-trim oct> >>uid
24 8 read-c-string* tar-trim oct> >>gid
25 12 read-c-string* tar-trim oct> >>size
26 12 read-c-string* tar-trim oct> >>mtime
27 8 read-c-string* tar-trim oct> >>checksum
29 100 read-c-string* >>linkname
32 32 read-c-string* >>uname
33 32 read-c-string* >>gname
34 8 read tar-trim oct> >>devmajor
35 8 read tar-trim oct> >>devminor
36 155 read-c-string* >>prefix ;
38 : header-checksum ( seq -- x )
39 148 cut-slice 8 tail-slice
42 : read-data-blocks ( tar-header -- )
45 over size>> dup block-size <= [
46 head-slice >byte-array write drop
49 [ block-size - ] change-size
59 : parse-tar-header ( seq -- obj )
60 [ header-checksum ] keep over zero-checksum = [
66 [ read-tar-header ] with-string-reader
67 [ checksum>> = [ checksum-error ] unless ] keep
70 ERROR: unknown-typeflag ch ;
71 M: unknown-typeflag summary ( obj -- str )
72 ch>> 1string "Unknown typeflag: " prepend ;
74 : tar-prepend-path ( path -- newpath )
75 base-dir get prepend-path ;
77 : read/write-blocks ( tar-header path -- )
78 binary [ read-data-blocks ] with-file-writer ;
81 : typeflag-0 ( header -- )
82 dup name>> tar-prepend-path read/write-blocks ;
85 : typeflag-1 ( header -- ) unknown-typeflag ;
88 : typeflag-2 ( header -- )
89 [ name>> ] [ linkname>> ] bi
90 [ make-link ] 2curry ignore-errors ;
93 : typeflag-3 ( header -- ) unknown-typeflag ;
96 : typeflag-4 ( header -- ) unknown-typeflag ;
99 : typeflag-5 ( header -- )
100 name>> tar-prepend-path make-directories ;
103 : typeflag-6 ( header -- ) unknown-typeflag ;
106 : typeflag-7 ( header -- ) unknown-typeflag ;
108 ! Global extended header
109 : typeflag-8 ( header -- ) unknown-typeflag ;
112 : typeflag-9 ( header -- ) unknown-typeflag ;
114 ! Global POSIX header
115 : typeflag-g ( header -- ) typeflag-0 ;
117 ! Extended POSIX header
118 : typeflag-x ( header -- ) unknown-typeflag ;
120 ! Solaris access control list
121 : typeflag-A ( header -- ) unknown-typeflag ;
124 : typeflag-D ( header -- ) unknown-typeflag ;
126 ! Solaris extended attribute file
127 : typeflag-E ( header -- ) unknown-typeflag ;
130 : typeflag-I ( header -- ) unknown-typeflag ;
133 : typeflag-K ( header -- ) unknown-typeflag ;
136 : typeflag-L ( header -- )
138 ! <string-writer> [ read-data-blocks ] keep
139 ! >string [ zero? ] trim-right filename set
140 ! filename get tar-prepend-path make-directories ;
142 ! Multi volume continuation entry
143 : typeflag-M ( header -- ) unknown-typeflag ;
146 : typeflag-N ( header -- ) unknown-typeflag ;
149 : typeflag-S ( header -- ) unknown-typeflag ;
152 : typeflag-V ( header -- ) unknown-typeflag ;
154 ! Vendor extended header type
155 : typeflag-X ( header -- ) unknown-typeflag ;
158 block-size read dup length 512 = [
163 { CHAR: 0 [ typeflag-0 ] }
164 ! { CHAR: 1 [ typeflag-1 ] }
165 { CHAR: 2 [ typeflag-2 ] }
166 ! { CHAR: 3 [ typeflag-3 ] }
167 ! { CHAR: 4 [ typeflag-4 ] }
168 { CHAR: 5 [ typeflag-5 ] }
169 ! { CHAR: 6 [ typeflag-6 ] }
170 ! { CHAR: 7 [ typeflag-7 ] }
171 { CHAR: g [ typeflag-g ] }
172 ! { CHAR: x [ typeflag-x ] }
173 ! { CHAR: A [ typeflag-A ] }
174 ! { CHAR: D [ typeflag-D ] }
175 ! { CHAR: E [ typeflag-E ] }
176 ! { CHAR: I [ typeflag-I ] }
177 ! { CHAR: K [ typeflag-K ] }
178 ! { CHAR: L [ typeflag-L ] }
179 ! { CHAR: M [ typeflag-M ] }
180 ! { CHAR: N [ typeflag-N ] }
181 ! { CHAR: S [ typeflag-S ] }
182 ! { CHAR: V [ typeflag-V ] }
183 ! { CHAR: X [ typeflag-X ] }
190 : parse-tar ( path -- )
191 normalize-path dup parent-directory base-dir [
192 binary [ (parse-tar) ] with-file-reader