extra/tar/tar.factor

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