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 ! Normal file
  89 : typeflag-0 ( header -- )
  90     dup name>> read/write-blocks ;
  91
  92 TUPLE: hard-link linkname name ;
  93 C: <hard-link> hard-link
  94
  95 TUPLE: symbolic-link linkname name ;
  96 C: <symbolic-link> symbolic-link
  97
  98 ! Hard link, don't call normalize-path
  99 : typeflag-1 ( header -- )
 100     [ linkname>> ] [ name>> ] bi <hard-link> save-link ;
 101
 102 ! Symlink, don't call normalize-path
 103 : typeflag-2 ( header -- )
 104     [ linkname>> ] [ name>> ] bi <symbolic-link> save-link ;
 105
 106 ! character special
 107 : typeflag-3 ( header -- ) unknown-typeflag ;
 108
 109 ! Block special
 110 : typeflag-4 ( header -- ) unknown-typeflag ;
 111
 112 ! Directory
 113 : typeflag-5 ( header -- )
 114     name>> make-directories ;
 115
 116 ! FIFO
 117 : typeflag-6 ( header -- ) unknown-typeflag ;
 118
 119 ! Contiguous file
 120 : typeflag-7 ( header -- ) unknown-typeflag ;
 121
 122 ! Global extended header
 123 : typeflag-8 ( header -- ) unknown-typeflag ;
 124
 125 ! Extended header
 126 : typeflag-9 ( header -- ) unknown-typeflag ;
 127
 128 ! Global POSIX header
 129 : typeflag-g ( header -- )
 130     ! Read something like: 52 comment=9f2a940965286754f3a34d5737c3097c05db8725
 131     ! and drop it
 132     [ read-data-blocks ] with-string-writer drop ;
 133
 134 ! Extended POSIX header
 135 : typeflag-x ( header -- ) unknown-typeflag ;
 136
 137 ! Solaris access control list
 138 : typeflag-A ( header -- ) unknown-typeflag ;
 139
 140 ! GNU dumpdir
 141 : typeflag-D ( header -- ) unknown-typeflag ;
 142
 143 ! Solaris extended attribute file
 144 : typeflag-E ( header -- ) unknown-typeflag ;
 145
 146 ! Inode metadata
 147 : typeflag-I ( header -- ) unknown-typeflag ;
 148
 149 ! Long link name
 150 : typeflag-K ( header -- ) unknown-typeflag ;
 151
 152 ! Long file name
 153 : typeflag-L ( header -- )
 154     drop
 155     ;
 156     ! [ read-data-blocks ] with-string-writer
 157     ! [ zero? ] trim-tail filename set
 158     ! filename get make-directories ;
 159
 160 ! Multi volume continuation entry
 161 : typeflag-M ( header -- ) unknown-typeflag ;
 162
 163 ! GNU long file name
 164 : typeflag-N ( header -- ) unknown-typeflag ;
 165
 166 ! Sparse file
 167 : typeflag-S ( header -- ) unknown-typeflag ;
 168
 169 ! Volume header
 170 : typeflag-V ( header -- ) unknown-typeflag ;
 171
 172 ! Vendor extended header type
 173 : typeflag-X ( header -- ) unknown-typeflag ;
 174
 175 : parse-tar ( -- )
 176     block-size read dup length block-size = [
 177         parse-tar-header
 178         dup typeflag>>
 179         {
 180             { 0 [ typeflag-0 ] }
 181             { CHAR: 0 [ typeflag-0 ] }
 182             ! { CHAR: 1 [ typeflag-1 ] }
 183             { CHAR: 2 [ typeflag-2 ] }
 184             ! { CHAR: 3 [ typeflag-3 ] }
 185             ! { CHAR: 4 [ typeflag-4 ] }
 186             { CHAR: 5 [ typeflag-5 ] }
 187             ! { CHAR: 6 [ typeflag-6 ] }
 188             ! { CHAR: 7 [ typeflag-7 ] }
 189             { CHAR: g [ typeflag-g ] }
 190             ! { CHAR: x [ typeflag-x ] }
 191             ! { CHAR: A [ typeflag-A ] }
 192             ! { CHAR: D [ typeflag-D ] }
 193             ! { CHAR: E [ typeflag-E ] }
 194             ! { CHAR: I [ typeflag-I ] }
 195             ! { CHAR: K [ typeflag-K ] }
 196             { CHAR: L [ typeflag-L ] }
 197             ! { CHAR: M [ typeflag-M ] }
 198             ! { CHAR: N [ typeflag-N ] }
 199             ! { CHAR: S [ typeflag-S ] }
 200             ! { CHAR: V [ typeflag-V ] }
 201             ! { CHAR: X [ typeflag-X ] }
 202             { f [ drop ] }
 203         } case parse-tar
 204     ] [
 205         drop
 206     ] if ;
 207
 208 GENERIC: do-link ( object -- )
 209
 210 M: hard-link do-link
 211     [ linkname>> ] [ name>> ] bi make-hard-link ;
 212
 213 M: symbolic-link do-link
 214     [ linkname>> ] [ name>> ] bi make-link ;
 215
 216 ! FIXME: linux tar calls unlinkat and makelinkat
 217 : make-links ( -- )
 218     to-link get [
 219         [ name>> ?delete-file ] [ do-link ] bi
 220     ] each ;
 221
 222 : untar ( path -- )
 223     normalize-path dup parent-directory [
 224         V{ } clone to-link [
 225             binary [ parse-tar ] with-file-reader
 226             make-links
 227         ] with-variable
 228     ] with-directory ;