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 IN: tar
   8
   9 CONSTANT: zero-checksum 256
  10 CONSTANT: block-size 512
  11
  12 SYMBOL: to-link
  13
  14 : save-link ( link -- )
  15     to-link get push ;
  16
  17 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
  18 linkname magic version uname gname devmajor devminor prefix ;
  19
  20 ERROR: 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
  79 ERROR: unknown-typeflag ch ;
  80
  81 M: 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
  94 TUPLE: hard-link linkname name ;
  95 C: <hard-link> hard-link
  96
  97 TUPLE: symbolic-link linkname name ;
  98 C: <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     ! [ read-data-blocks ] with-string-writer
 159     ! [ 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
 210 GENERIC: do-link ( object -- )
 211
 212 M: hard-link do-link
 213     [ linkname>> ]
 214     [ name>> prepend-current-directory ] bi make-hard-link ;
 215
 216 M: 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 ;