extra/tar/tar.factor

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