/extra/tar/tar.factor

  1! Copyright (C) 2009 Doug Coleman.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: accessors byte-arrays combinators io io.backend
  4io.directories io.encodings.binary io.files io.files.links
  5io.pathnames io.streams.byte-array io.streams.string kernel
  6math math.parser namespaces sequences strings summary ;
  7IN: tar
  8
  9CONSTANT: zero-checksum 256
 10CONSTANT: block-size 512
 11
 12SYMBOL: to-link
 13
 14: save-link ( link -- )
 15    to-link get push ;
 16
 17TUPLE: tar-header name mode uid gid size mtime checksum typeflag
 18linkname magic version uname gname devmajor devminor prefix ;
 19
 20ERROR: checksum-error header ;
 21
 22: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
 23
 24: read-c-string ( n -- str/f )
 25    read [ zero? ] trim-tail [ f ] when-empty >string ;
 26
 27: read-tar-header ( -- obj )
 28    \ tar-header new
 29        100 read-c-string >>name
 30        8 read-c-string trim-string oct> >>mode
 31        8 read-c-string trim-string oct> >>uid
 32        8 read-c-string trim-string oct> >>gid
 33        12 read-c-string trim-string oct> >>size
 34        12 read-c-string trim-string oct> >>mtime
 35        8 read-c-string trim-string oct> >>checksum
 36        read1 >>typeflag
 37        100 read-c-string >>linkname
 38        6 read >>magic
 39        2 read >>version
 40        32 read-c-string >>uname
 41        32 read-c-string >>gname
 42        8 read trim-string oct> >>devmajor
 43        8 read trim-string oct> >>devminor
 44        155 read-c-string >>prefix ;
 45
 46: checksum-header ( seq -- n )
 47    148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
 48
 49: read-data-blocks ( tar-header -- )
 50    dup size>> 0 > [
 51        block-size read [
 52            over size>> dup block-size <= [
 53                head-slice >byte-array write drop
 54            ] [
 55                drop write
 56                [ block-size - ] change-size
 57                read-data-blocks
 58            ] if
 59        ] [
 60            drop
 61        ] if*
 62    ] [
 63        drop
 64    ] if ;
 65
 66: parse-tar-header ( seq -- obj )
 67    dup checksum-header dup zero-checksum = [
 68        2drop
 69        \ tar-header new
 70            0 >>size
 71            0 >>checksum
 72    ] [
 73        [
 74            binary [ read-tar-header ] with-byte-reader
 75            dup checksum>>
 76        ] dip = [ checksum-error ] unless
 77    ] if ;
 78
 79ERROR: unknown-typeflag ch ;
 80
 81M: unknown-typeflag summary ( obj -- str )
 82    ch>> [ "Unknown typeflag: " ] dip prefix ;
 83
 84: read/write-blocks ( tar-header path -- )
 85    binary [ read-data-blocks ] with-file-writer ;
 86
 87: prepend-current-directory ( path -- path' )
 88    current-directory get prepend-path ;
 89
 90! Normal file
 91: typeflag-0 ( header -- )
 92    dup name>> prepend-current-directory read/write-blocks ;
 93
 94TUPLE: hard-link linkname name ;
 95C: <hard-link> hard-link
 96
 97TUPLE: symbolic-link linkname name ;
 98C: <symbolic-link> symbolic-link
 99
100! Hard link, don't call normalize-path
101: typeflag-1 ( header -- )
102    [ linkname>> ] [ name>> ] bi <hard-link> save-link ;
103
104! Symlink, don't call normalize-path
105: typeflag-2 ( header -- )
106    [ linkname>> ] [ name>> ] bi <symbolic-link> save-link ;
107
108! character special
109: typeflag-3 ( header -- ) unknown-typeflag ;
110
111! Block special
112: typeflag-4 ( header -- ) unknown-typeflag ;
113
114! Directory
115: typeflag-5 ( header -- )
116    name>> prepend-current-directory make-directories ;
117
118! FIFO
119: typeflag-6 ( header -- ) unknown-typeflag ;
120
121! Contiguous file
122: typeflag-7 ( header -- ) unknown-typeflag ;
123
124! Global extended header
125: typeflag-8 ( header -- ) unknown-typeflag ;
126
127! Extended header
128: typeflag-9 ( header -- ) unknown-typeflag ;
129
130! Global POSIX header
131: typeflag-g ( header -- )
132    ! Read something like: 52 comment=9f2a940965286754f3a34d5737c3097c05db8725
133    ! and drop it
134    [ read-data-blocks ] with-string-writer drop ;
135
136! Extended POSIX header
137: typeflag-x ( header -- ) unknown-typeflag ;
138
139! Solaris access control list
140: typeflag-A ( header -- ) unknown-typeflag ;
141
142! GNU dumpdir
143: typeflag-D ( header -- ) unknown-typeflag ;
144
145! Solaris extended attribute file
146: typeflag-E ( header -- ) unknown-typeflag ;
147
148! Inode metadata
149: typeflag-I ( header -- ) unknown-typeflag ;
150
151! Long link name
152: typeflag-K ( header -- ) unknown-typeflag ;
153
154! Long file name
155: typeflag-L ( header -- )
156    drop
157    ;
158    ! <string-writer> [ read-data-blocks ] keep
159    ! >string [ zero? ] trim-tail filename set
160    ! filename get prepend-current-directory make-directories ;
161
162! Multi volume continuation entry
163: typeflag-M ( header -- ) unknown-typeflag ;
164
165! GNU long file name
166: typeflag-N ( header -- ) unknown-typeflag ;
167
168! Sparse file
169: typeflag-S ( header -- ) unknown-typeflag ;
170
171! Volume header
172: typeflag-V ( header -- ) unknown-typeflag ;
173
174! Vendor extended header type
175: typeflag-X ( header -- ) unknown-typeflag ;
176
177: parse-tar ( -- )
178    block-size read dup length block-size = [
179        parse-tar-header
180        dup typeflag>>
181        {
182            { 0 [ typeflag-0 ] }
183            { CHAR: 0 [ typeflag-0 ] }
184            ! { CHAR: 1 [ typeflag-1 ] }
185            { CHAR: 2 [ typeflag-2 ] }
186            ! { CHAR: 3 [ typeflag-3 ] }
187            ! { CHAR: 4 [ typeflag-4 ] }
188            { CHAR: 5 [ typeflag-5 ] }
189            ! { CHAR: 6 [ typeflag-6 ] }
190            ! { CHAR: 7 [ typeflag-7 ] }
191            { CHAR: g [ typeflag-g ] }
192            ! { CHAR: x [ typeflag-x ] }
193            ! { CHAR: A [ typeflag-A ] }
194            ! { CHAR: D [ typeflag-D ] }
195            ! { CHAR: E [ typeflag-E ] }
196            ! { CHAR: I [ typeflag-I ] }
197            ! { CHAR: K [ typeflag-K ] }
198            { CHAR: L [ typeflag-L ] }
199            ! { CHAR: M [ typeflag-M ] }
200            ! { CHAR: N [ typeflag-N ] }
201            ! { CHAR: S [ typeflag-S ] }
202            ! { CHAR: V [ typeflag-V ] }
203            ! { CHAR: X [ typeflag-X ] }
204            { f [ drop ] }
205        } case parse-tar
206    ] [
207        drop
208    ] if ;
209
210GENERIC: do-link ( object -- )
211
212M: hard-link do-link
213    [ linkname>> ]
214    [ name>> prepend-current-directory ] bi make-hard-link ;
215
216M: symbolic-link do-link
217    [ linkname>> ]
218    [ name>> prepend-current-directory ] bi make-link ;
219
220! FIXME: linux tar calls unlinkat and makelinkat
221: make-links ( -- )
222    to-link get [
223        [ name>> ?delete-file ] [ do-link ] bi
224    ] each ;
225
226: untar ( path -- )
227    normalize-path dup parent-directory [
228        V{ } clone to-link [
229            binary [ parse-tar ] with-file-reader
230            make-links
231        ] with-variable
232    ] with-directory ;