1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: combinators io io.files io.files.links io.directories
4 io.pathnames io.streams.string kernel math math.parser
5 continuations namespaces pack prettyprint sequences strings
6 system tools.hexdump io.encodings.binary summary accessors
7 io.backend byte-arrays io.streams.byte-array splitting ;
10 CONSTANT: zero-checksum 256
11 CONSTANT: block-size 512
13 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
14 linkname magic version uname gname devmajor devminor prefix ;
16 ERROR: checksum-error header ;
18 : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
20 : read-c-string ( n -- str/f )
21 read [ zero? ] trim-tail [ f ] when-empty >string ;
23 : read-tar-header ( -- obj )
25 100 read-c-string >>name
26 8 read-c-string trim-string oct> >>mode
27 8 read-c-string trim-string oct> >>uid
28 8 read-c-string trim-string oct> >>gid
29 12 read-c-string trim-string oct> >>size
30 12 read-c-string trim-string oct> >>mtime
31 8 read-c-string trim-string oct> >>checksum
33 100 read-c-string >>linkname
36 32 read-c-string >>uname
37 32 read-c-string >>gname
38 8 read trim-string oct> >>devmajor
39 8 read trim-string oct> >>devminor
40 155 read-c-string >>prefix ;
42 : checksum-header ( seq -- n )
43 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
45 : read-data-blocks ( tar-header -- )
48 over size>> dup block-size <= [
49 head-slice >byte-array write drop
52 [ block-size - ] change-size
62 : parse-tar-header ( seq -- obj )
63 dup checksum-header dup zero-checksum = [
70 binary [ read-tar-header ] with-byte-reader
72 ] dip = [ checksum-error ] unless
75 ERROR: unknown-typeflag ch ;
77 M: unknown-typeflag summary ( obj -- str )
78 ch>> [ "Unknown typeflag: " ] dip prefix ;
80 : read/write-blocks ( tar-header path -- )
81 binary [ read-data-blocks ] with-file-writer ;
83 : prepend-current-directory ( path -- path' )
84 current-directory get prepend-path ;
87 : typeflag-0 ( header -- )
88 dup name>> dup "global_pax_header" = [
89 drop [ read-data-blocks ] with-string-writer drop
91 prepend-current-directory read/write-blocks
95 : typeflag-1 ( header -- )
96 [ name>> ] [ linkname>> ] bi make-hard-link ;
99 : typeflag-2 ( header -- )
100 [ name>> ] [ linkname>> ] bi make-link ;
103 : typeflag-3 ( header -- ) unknown-typeflag ;
106 : typeflag-4 ( header -- ) unknown-typeflag ;
109 : typeflag-5 ( header -- )
110 name>> prepend-current-directory make-directories ;
113 : typeflag-6 ( header -- ) unknown-typeflag ;
116 : typeflag-7 ( header -- ) unknown-typeflag ;
118 ! Global extended header
119 : typeflag-8 ( header -- ) unknown-typeflag ;
122 : typeflag-9 ( header -- ) unknown-typeflag ;
124 ! Global POSIX header
125 : typeflag-g ( header -- ) typeflag-0 ;
127 ! Extended POSIX header
128 : typeflag-x ( header -- ) unknown-typeflag ;
130 ! Solaris access control list
131 : typeflag-A ( header -- ) unknown-typeflag ;
134 : typeflag-D ( header -- ) unknown-typeflag ;
136 ! Solaris extended attribute file
137 : typeflag-E ( header -- ) unknown-typeflag ;
140 : typeflag-I ( header -- ) unknown-typeflag ;
143 : typeflag-K ( header -- ) unknown-typeflag ;
146 : typeflag-L ( header -- )
149 ! <string-writer> [ read-data-blocks ] keep
150 ! >string [ zero? ] trim-tail filename set
151 ! filename get prepend-current-directory make-directories ;
153 ! Multi volume continuation entry
154 : typeflag-M ( header -- ) unknown-typeflag ;
157 : typeflag-N ( header -- ) unknown-typeflag ;
160 : typeflag-S ( header -- ) unknown-typeflag ;
163 : typeflag-V ( header -- ) unknown-typeflag ;
165 ! Vendor extended header type
166 : typeflag-X ( header -- ) unknown-typeflag ;
169 block-size read dup length block-size = [
174 { CHAR: 0 [ typeflag-0 ] }
175 ! { CHAR: 1 [ typeflag-1 ] }
176 { CHAR: 2 [ typeflag-2 ] }
177 ! { CHAR: 3 [ typeflag-3 ] }
178 ! { CHAR: 4 [ typeflag-4 ] }
179 { CHAR: 5 [ typeflag-5 ] }
180 ! { CHAR: 6 [ typeflag-6 ] }
181 ! { CHAR: 7 [ typeflag-7 ] }
182 { CHAR: g [ typeflag-g ] }
183 ! { CHAR: x [ typeflag-x ] }
184 ! { CHAR: A [ typeflag-A ] }
185 ! { CHAR: D [ typeflag-D ] }
186 ! { CHAR: E [ typeflag-E ] }
187 ! { CHAR: I [ typeflag-I ] }
188 ! { CHAR: K [ typeflag-K ] }
189 { CHAR: L [ typeflag-L ] }
190 ! { CHAR: M [ typeflag-M ] }
191 ! { CHAR: N [ typeflag-N ] }
192 ! { CHAR: S [ typeflag-S ] }
193 ! { CHAR: V [ typeflag-V ] }
194 ! { CHAR: X [ typeflag-X ] }
202 normalize-path dup parent-directory [
203 binary [ parse-tar ] with-file-reader