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 CONSTANT: zero-checksum 256
   9 CONSTANT: block-size 512
  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-tail [ 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 make-link ;
  93
  94 ! character special
  95 : typeflag-3 ( header -- ) unknown-typeflag ;
  96
  97 ! Block special
  98 : typeflag-4 ( header -- ) unknown-typeflag ;
  99
 100 ! Directory
 101 : typeflag-5 ( header -- )
 102     name>> tar-prepend-path make-directories ;
 103
 104 ! FIFO
 105 : typeflag-6 ( header -- ) unknown-typeflag ;
 106
 107 ! Contiguous file
 108 : typeflag-7 ( header -- ) unknown-typeflag ;
 109
 110 ! Global extended header
 111 : typeflag-8 ( header -- ) unknown-typeflag ;
 112
 113 ! Extended header
 114 : typeflag-9 ( header -- ) unknown-typeflag ;
 115
 116 ! Global POSIX header
 117 : typeflag-g ( header -- ) typeflag-0 ;
 118
 119 ! Extended POSIX header
 120 : typeflag-x ( header -- ) unknown-typeflag ;
 121
 122 ! Solaris access control list
 123 : typeflag-A ( header -- ) unknown-typeflag ;
 124
 125 ! GNU dumpdir
 126 : typeflag-D ( header -- ) unknown-typeflag ;
 127
 128 ! Solaris extended attribute file
 129 : typeflag-E ( header -- ) unknown-typeflag ;
 130
 131 ! Inode metadata
 132 : typeflag-I ( header -- ) unknown-typeflag ;
 133
 134 ! Long link name
 135 : typeflag-K ( header -- ) unknown-typeflag ;
 136
 137 ! Long file name
 138 : typeflag-L ( header -- )
 139     drop ;
 140     ! <string-writer> [ read-data-blocks ] keep
 141     ! >string [ zero? ] trim-tail filename set
 142     ! filename get tar-prepend-path make-directories ;
 143
 144 ! Multi volume continuation entry
 145 : typeflag-M ( header -- ) unknown-typeflag ;
 146
 147 ! GNU long file name
 148 : typeflag-N ( header -- ) unknown-typeflag ;
 149
 150 ! Sparse file
 151 : typeflag-S ( header -- ) unknown-typeflag ;
 152
 153 ! Volume header
 154 : typeflag-V ( header -- ) unknown-typeflag ;
 155
 156 ! Vendor extended header type
 157 : typeflag-X ( header -- ) unknown-typeflag ;
 158
 159 : (parse-tar) ( -- )
 160     block-size read dup length 512 = [
 161         parse-tar-header
 162         dup typeflag>>
 163         {
 164             { 0 [ typeflag-0 ] }
 165             { CHAR: 0 [ typeflag-0 ] }
 166             ! { CHAR: 1 [ typeflag-1 ] }
 167             { CHAR: 2 [ typeflag-2 ] }
 168             ! { CHAR: 3 [ typeflag-3 ] }
 169             ! { CHAR: 4 [ typeflag-4 ] }
 170             { CHAR: 5 [ typeflag-5 ] }
 171             ! { CHAR: 6 [ typeflag-6 ] }
 172             ! { CHAR: 7 [ typeflag-7 ] }
 173             { CHAR: g [ typeflag-g ] }
 174             ! { CHAR: x [ typeflag-x ] }
 175             ! { CHAR: A [ typeflag-A ] }
 176             ! { CHAR: D [ typeflag-D ] }
 177             ! { CHAR: E [ typeflag-E ] }
 178             ! { CHAR: I [ typeflag-I ] }
 179             ! { CHAR: K [ typeflag-K ] }
 180             ! { CHAR: L [ typeflag-L ] }
 181             ! { CHAR: M [ typeflag-M ] }
 182             ! { CHAR: N [ typeflag-N ] }
 183             ! { CHAR: S [ typeflag-S ] }
 184             ! { CHAR: V [ typeflag-V ] }
 185             ! { CHAR: X [ typeflag-X ] }
 186             { f [ drop ] }
 187         } case (parse-tar)
 188     ] [
 189         drop
 190     ] if ;
 191
 192 : parse-tar ( path -- )
 193     normalize-path dup parent-directory base-dir [
 194          binary [ (parse-tar) ] with-file-reader
 195     ] with-variable ;