]> gitweb.factorcode.org Git - factor.git/blob - extra/tar/tar.factor
Merge branch 'master' of git://factorcode.org/git/factor
[factor.git] / extra / tar / tar.factor
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 ;
8 IN: tar
9
10 CONSTANT: zero-checksum 256
11 CONSTANT: block-size 512
12
13 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
14 linkname magic version uname gname devmajor devminor prefix ;
15
16 ERROR: checksum-error ;
17
18 : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
19
20 : read-c-string ( n -- str/f )
21     read [ zero? ] trim-tail [ f ] when-empty ;
22
23 : read-tar-header ( -- obj )
24     \ tar-header new
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
32         read1 >>typeflag
33         100 read-c-string >>linkname
34         6 read >>magic
35         2 read >>version
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 ;
41
42 : checksum-header ( seq -- n )
43     148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
44
45 : read-data-blocks ( tar-header -- )
46     dup size>> 0 > [
47         block-size read [
48             over size>> dup block-size <= [
49                 head-slice >byte-array write drop
50             ] [
51                 drop write
52                 [ block-size - ] change-size
53                 read-data-blocks
54             ] if
55         ] [
56             drop
57         ] if*
58     ] [
59         drop
60     ] if ;
61
62 : parse-tar-header ( seq -- obj )
63     [ checksum-header ] keep over zero-checksum = [
64         2drop
65         \ tar-header new
66             0 >>size
67             0 >>checksum
68     ] [
69         binary [ read-tar-header ] with-byte-reader
70         [ checksum>> = [ checksum-error ] unless ] keep
71     ] if ;
72
73 ERROR: unknown-typeflag ch ;
74
75 M: unknown-typeflag summary ( obj -- str )
76     ch>> [ "Unknown typeflag: " ] dip prefix ;
77
78 : read/write-blocks ( tar-header path -- )
79     binary [ read-data-blocks ] with-file-writer ;
80
81 : prepend-current-directory ( path -- path' )
82     current-directory get prepend-path ;
83
84 ! Normal file
85 : typeflag-0 ( header -- )
86     dup name>> dup "global_pax_header" = [
87         drop [ read-data-blocks ] with-string-writer drop
88     ] [
89         prepend-current-directory read/write-blocks
90     ] if ;
91
92 ! Hard link
93 : typeflag-1 ( header -- ) unknown-typeflag ;
94
95 ! Symlink
96 : typeflag-2 ( header -- )
97     [ name>> ] [ linkname>> ] bi make-link ;
98
99 ! character special
100 : typeflag-3 ( header -- ) unknown-typeflag ;
101
102 ! Block special
103 : typeflag-4 ( header -- ) unknown-typeflag ;
104
105 ! Directory
106 : typeflag-5 ( header -- )
107     name>> prepend-current-directory make-directories ;
108
109 ! FIFO
110 : typeflag-6 ( header -- ) unknown-typeflag ;
111
112 ! Contiguous file
113 : typeflag-7 ( header -- ) unknown-typeflag ;
114
115 ! Global extended header
116 : typeflag-8 ( header -- ) unknown-typeflag ;
117
118 ! Extended header
119 : typeflag-9 ( header -- ) unknown-typeflag ;
120
121 ! Global POSIX header
122 : typeflag-g ( header -- ) typeflag-0 ;
123
124 ! Extended POSIX header
125 : typeflag-x ( header -- ) unknown-typeflag ;
126
127 ! Solaris access control list
128 : typeflag-A ( header -- ) unknown-typeflag ;
129
130 ! GNU dumpdir
131 : typeflag-D ( header -- ) unknown-typeflag ;
132
133 ! Solaris extended attribute file
134 : typeflag-E ( header -- ) unknown-typeflag ;
135
136 ! Inode metadata
137 : typeflag-I ( header -- ) unknown-typeflag ;
138
139 ! Long link name
140 : typeflag-K ( header -- ) unknown-typeflag ;
141
142 ! Long file name
143 : typeflag-L ( header -- )
144     drop ;
145     ! <string-writer> [ read-data-blocks ] keep
146     ! >string [ zero? ] trim-tail filename set
147     ! filename get prepend-current-directory make-directories ;
148
149 ! Multi volume continuation entry
150 : typeflag-M ( header -- ) unknown-typeflag ;
151
152 ! GNU long file name
153 : typeflag-N ( header -- ) unknown-typeflag ;
154
155 ! Sparse file
156 : typeflag-S ( header -- ) unknown-typeflag ;
157
158 ! Volume header
159 : typeflag-V ( header -- ) unknown-typeflag ;
160
161 ! Vendor extended header type
162 : typeflag-X ( header -- ) unknown-typeflag ;
163
164 : (parse-tar) ( -- )
165     block-size read dup length block-size = [
166         parse-tar-header
167         dup typeflag>>
168         {
169             { 0 [ typeflag-0 ] }
170             { CHAR: 0 [ typeflag-0 ] }
171             ! { CHAR: 1 [ typeflag-1 ] }
172             { CHAR: 2 [ typeflag-2 ] }
173             ! { CHAR: 3 [ typeflag-3 ] }
174             ! { CHAR: 4 [ typeflag-4 ] }
175             { CHAR: 5 [ typeflag-5 ] }
176             ! { CHAR: 6 [ typeflag-6 ] }
177             ! { CHAR: 7 [ typeflag-7 ] }
178             { CHAR: g [ typeflag-g ] }
179             ! { CHAR: x [ typeflag-x ] }
180             ! { CHAR: A [ typeflag-A ] }
181             ! { CHAR: D [ typeflag-D ] }
182             ! { CHAR: E [ typeflag-E ] }
183             ! { CHAR: I [ typeflag-I ] }
184             ! { CHAR: K [ typeflag-K ] }
185             ! { CHAR: L [ typeflag-L ] }
186             ! { CHAR: M [ typeflag-M ] }
187             ! { CHAR: N [ typeflag-N ] }
188             ! { CHAR: S [ typeflag-S ] }
189             ! { CHAR: V [ typeflag-V ] }
190             ! { CHAR: X [ typeflag-X ] }
191             { f [ drop ] }
192         } case (parse-tar)
193     ] [
194         drop
195     ] if ;
196
197 : untar ( path -- )
198     normalize-path [ ] [ parent-directory ] bi [
199          binary [ (parse-tar) ] with-file-reader
200     ] with-directory ;