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