extra/tar/tar.factor

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