extra/tar/tar.factor

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