src/utils/cdk/tar.mlcpp

   1 #include "../../../config/config.h"
   2
   3 exception Error of string
   4
   5 (* Types of files recongized by tar *)
   6 type file_type = REGULAR | LINK | SYMLINK | CHRSPEC | BLKSPEC | DIRECTORY | FIFO  | CONTIGIOUS | DUMPDIR (** GNU: A dir entry that contains the names of files that were in the dir at the time the dump was made. *) | LONGLINK (** GNU: Identifies the *next* file on the archive as having a long linkname *)| LONGNAME (** GNU: Identifies the *next* file on the tape as having a long name. *) | MULTIVOL (** GNU: The continuation of a file that began on another volume. *) | NAMES (** GNU: For storing filenames tha do not fit into the main header. *) | SPARSE (** GNU: Sparse file *) | VOLHDR (** GNU: This file is a tape/volume header. Ignore it on extraction. *)
   7
   8 type record_type = POSIX_FORMAT | GNU_FORMAT | OLDGNU_FORMAT | V7_FORMAT
   9
  10 (* The size of a header block *)
  11 let blocksize = 512
  12
  13 (* The metadata for a file in a tar archive *)
  14 type header = {
  15   t_name: string;
  16   t_mode: int;
  17   t_uid: int;
  18   t_gid: int;
  19   t_size: int;
  20   t_mtime: int32;
  21   t_chksum: int;
  22   t_typeflag: file_type;
  23   t_linkname: string;
  24   t_format: record_type;
  25   t_uname: string;
  26   t_gname: string;
  27   t_devmajor: int;
  28   t_devminor: int;
  29   t_prefix: string;
  30   t_gnu: gnu_extras option
  31 }
  32 and gnu_extras = {
  33   t_atime: int32;
  34   t_ctime: int32;
  35   t_offset: int32;
  36   t_realsize: int32;
  37 }
  38
  39 class in_chan i = object
  40   method really_input str pos len =
  41     try Pervasives.really_input i str pos len with
  42         End_of_file -> raise (Error "Unexpected end of file")
  43   method input str pos len =
  44     try Pervasives.input i str pos len with
  45         End_of_file -> raise (Error "Unexpected end of file")
  46   method dispose () = ()
  47   method close () = Pervasives.close_in i
  48 end
  49
  50 class gzin_chan i = object
  51   method really_input str pos len =
  52     try Gzip.really_input i str pos len with
  53         End_of_file -> raise (Error "Unexpected end of file")
  54   method input str pos len =
  55     try Gzip.input i str pos len with
  56         End_of_file -> raise (Error "Unexpected end of file")
  57   method dispose () = Gzip.dispose i
  58   method close () = Gzip.close_in i
  59 end
  60
  61 #ifdef USE_BZIP2
  62 class bzin_chan i = object
  63   method really_input str pos len =
  64     try Bzip2.really_input i str pos len with
  65         End_of_file -> raise (Error "Unexpected end of file")
  66   method input str pos len =
  67     try Bzip2.input i str pos len with
  68         End_of_file -> raise (Error "Unexpected end of file")
  69   method dispose () = Bzip2.dispose i
  70   method close () = Bzip2.close_in i
  71 end
  72 #endif
  73
  74
  75 let open_inchan comp chan =
  76   match comp with
  77     | `Plain -> new in_chan chan
  78     | `Gzip -> new gzin_chan (Gzip.open_in_chan chan)
  79     | `Bzip2 ->
  80 #ifdef USE_BZIP2
  81         new bzin_chan (Bzip2.open_in_chan chan)
  82 #else
  83         failwith "bzip2 not supported"
  84 #endif
  85
  86 let pick_comp_type filename = function
  87   | `Gzip -> `Gzip
  88   | `Bzip2 -> `Bzip2
  89   | `Plain -> `Plain
  90   | `Guess ->
  91       if Filename.check_suffix filename ".tar" then
  92         `Plain
  93 #ifdef USE_BZIP2
  94       else if Filename.check_suffix filename ".bz2" then
  95         `Bzip2
  96 #endif
  97       else if Filename.check_suffix filename ".gz"
  98         || Filename.check_suffix filename ".Z"
  99         || Filename.check_suffix filename ".tgz" then
 100           `Gzip
 101       else
 102         `Plain
 103
 104 type t_in = {
 105   chan: in_chan;
 106   rawchan: in_channel;
 107   mutable last_header: header option;
 108 }
 109
 110 let open_in_chan ?(compress=`Plain) chan =
 111   {
 112     chan = open_inchan compress chan;
 113     rawchan = chan;
 114     last_header = None;
 115   }
 116
 117 let open_in ?(compress=`Guess) filename =
 118   open_in_chan ~compress:(pick_comp_type filename compress) (open_in_bin filename)
 119
 120
 121 let dispose t = t.chan#dispose ()
 122 and close_in t = t.chan#close ()
 123
 124 (* Add Error Checking! *)
 125 let c_string raw start =
 126   let nul = String.index_from raw start '\000' in
 127     String.sub raw start (nul - start)
 128
 129 (* Numbers are /supposed/ to be 0 padded, octal, with a trailing "\000". About the only thing that s universal about this is octal. *)
 130 let trim_spaces str pos len =
 131   let start = ref pos
 132   and stop = ref (pos + len - 1) in
 133     while str.[!start] = ' ' do incr start done;
 134     while str.[!stop] = ' ' || str.[!stop] = '\000' do decr stop done;
 135     String.sub str !start (!stop - !start + 1)
 136
 137 let extract_num raw pos len =
 138   if raw.[pos] = '\000' then 0
 139   else try
 140     int_of_string ("0o" ^ (trim_spaces raw pos len))
 141   with Failure x -> raise (Error "Invalid number in header")
 142
 143 let extract_int32 raw pos len =
 144   if raw.[pos] = '\000' then 0l
 145   else try
 146     Int32.of_string ("0o" ^ trim_spaces raw pos len)
 147   with Failure x ->  raise (Error "Invalid number in header")
 148
 149 let typeflag = function
 150   | '0' | '\000' -> REGULAR
 151   | '1' -> LINK
 152   | '2' -> SYMLINK
 153   | '3' -> CHRSPEC
 154   | '4' -> BLKSPEC
 155   | '5' -> DIRECTORY
 156   | '6' -> FIFO
 157   | '7' -> CONTIGIOUS
 158   | 'D' -> DUMPDIR
 159   | 'K' -> LONGLINK
 160   | 'L' -> LONGNAME
 161   | 'M' -> MULTIVOL
 162   | 'N' -> NAMES
 163   | 'S' -> raise (Error "Sparse files are not supported")
 164   | 'V' -> VOLHDR
 165   | _ -> raise (Error "Unknown file type")
 166
 167 let align_at_header t =
 168   match t.last_header with
 169     | None -> ()
 170     | Some h ->
 171         let entry_size = ((h.t_size/blocksize) + 1) * blocksize
 172         and buf = String.create blocksize
 173         and discarded = ref 0 in
 174           while !discarded < entry_size do
 175             let read = t.chan#input buf 0 blocksize in
 176               discarded := !discarded + read
 177           done;
 178           t.last_header <- None
 179
 180 let empty_block = String.make blocksize '\000'
 181
 182 let compute_chksum buf =
 183   let chksum = ref 256 in (* 256 is the sum of 8 ' ' characters for the chksum field *)
 184     for i = 0 to 147 do
 185       chksum := !chksum + Char.code buf.[i]
 186     done;
 187     for i = 156 to 511 do
 188       chksum := !chksum + Char.code buf.[i]
 189     done;
 190     !chksum
 191
 192 let read_magic header typec =
 193   let magic = String.sub header 257 8 in
 194     match magic with
 195       | "ustar  \000" -> OLDGNU_FORMAT
 196       | "ustar\00000" -> begin match typec with
 197           | '0' .. '7' -> POSIX_FORMAT | _ -> GNU_FORMAT
 198         end
 199       | _ -> V7_FORMAT
 200
 201 let read_oldgnu_header header =
 202   { t_atime = extract_int32 header 345 12;
 203     t_ctime = extract_int32 header 357 12;
 204     t_offset = extract_int32 header 369 12;
 205     t_realsize = extract_int32 header 483 12;
 206   }
 207
 208 let read_gnu_header t =
 209   let buf = String.create blocksize in
 210     t.chan#really_input buf 0 blocksize;
 211     { t_atime = extract_int32 buf 0 12;
 212       t_ctime = extract_int32 buf 12 12;
 213       t_offset = extract_int32 buf 24 12;
 214       t_realsize = extract_int32 buf 36 12;
 215     }
 216
 217 let read_header t =
 218   align_at_header t;
 219   let buf = String.create blocksize in
 220     t.chan#really_input buf 0 blocksize;
 221     if buf = empty_block then raise End_of_file;
 222     let head1 = { t_name = c_string buf 0;
 223                  t_mode = extract_num buf 100 8;
 224                  t_uid = extract_num buf 108 8;
 225                  t_gid = extract_num buf 116 8;
 226                  t_size = extract_num buf 124 12;
 227                  t_mtime = extract_int32 buf 136 12;
 228                  t_chksum = extract_num buf 148 8;
 229                  t_typeflag = typeflag buf.[156];
 230                  t_linkname = c_string buf 157;
 231                  t_format = read_magic buf buf.[156];
 232                  t_uname = c_string buf 265;
 233                  t_gname = c_string buf 297;
 234                  t_devmajor = extract_num buf 329 8;
 235                  t_devminor = extract_num buf 337 8;
 236                  t_prefix = String.sub buf 345 155;
 237                  t_gnu = None;
 238                } in
 239     let chksum = compute_chksum buf in
 240       if chksum <> head1.t_chksum then
 241         raise (Error (Printf.sprintf "Invalid checksum in tar header. Calculated %d, expected %d" chksum head1.t_chksum));
 242       let head =
 243         if head1.t_format = OLDGNU_FORMAT then
 244           {head1 with t_gnu = Some (read_oldgnu_header buf) }
 245         else if head1.t_format = GNU_FORMAT then
 246           {head1 with t_gnu = Some (read_gnu_header t) }
 247         else
 248           head1 in
 249       t.last_header <- Some head;
 250       head
 251
 252 let align_at_body t =
 253   match t.last_header with
 254     | Some _ -> ()
 255     | None -> ignore (read_header t)
 256
 257 let get_header t =
 258   match t.last_header with
 259     | Some h -> h
 260     | None -> raise (Error "Missing tar header?")
 261
 262 let read_body t =
 263   align_at_body t;
 264   let header = get_header t in
 265     t.last_header <- None;
 266     if header.t_size = 0 then ""
 267     else let buf = String.create header.t_size in
 268       t.chan#really_input buf 0 header.t_size;
 269       let align = blocksize - (header.t_size mod blocksize) in
 270         if align <> blocksize then begin
 271           let leftover = String.create blocksize in
 272             t.chan#really_input leftover 0 align
 273         end;
 274         buf
 275
 276 let read_entry t =
 277   let head = read_header t in
 278     head, read_body t
 279
 280 class out_chan o = object
 281   method output str pos len = Pervasives.output o str pos len
 282   method flush () = Pervasives.flush o
 283   method close () = Pervasives.close_out o
 284 end
 285
 286 class gzout_chan o = object
 287   method output str pos len = Gzip.output o str pos len
 288   method flush () = Gzip.flush o
 289   method close () = Gzip.close_out o
 290 end
 291
 292 #ifdef USE_BZIP2
 293 class bzout_chan o = object
 294   method output str pos len = Bzip2.output o str pos len
 295   method flush () = Bzip2.flush o
 296   method close () = Bzip2.close_out o
 297 end
 298 #endif
 299
 300
 301 let open_outchan comp chan =
 302   match comp with
 303     | `Plain -> new out_chan chan
 304     | `Gzip -> new gzout_chan (Gzip.open_out_chan chan)
 305     | `Bzip2 ->
 306 #ifdef USE_BZIP2
 307         new bzout_chan (Bzip2.open_out_chan chan)
 308 #else
 309         failwith "bzip2 not supported"
 310 #endif
 311
 312 type t_out = {
 313   ochan: out_chan;
 314   rawochan: out_channel;
 315 }
 316
 317 let open_out_chan ?(compress=`Plain) chan =
 318   {
 319     ochan = open_outchan compress chan;
 320     rawochan = chan;
 321   }
 322
 323 let open_out ?(compress=`Plain) filename =
 324   open_out_chan ~compress (open_out_bin filename)
 325
 326 let write_str buf pos width str =
 327   let len = min (String.length str) (width - 1) in
 328     String.blit str 0 buf pos len
 329
 330 let write_num8 buf pos n =
 331   let as_str = Printf.sprintf "%07o" n in
 332     String.blit as_str 0 buf pos 7
 333
 334 let write_num12 buf pos n =
 335   let as_str = Printf.sprintf "%011o" n in
 336     String.blit as_str 0 buf pos 11
 337
 338 let write_int32 buf pos n =
 339   let as_str = Printf.sprintf "%011lo" n in
 340     String.blit as_str 0 buf pos 11
 341
 342 let write_padded_num buf pos n =
 343   let as_str = Printf.sprintf "%07o\000 " n in
 344     String.blit as_str 0 buf pos 8
 345
 346 let write_magic buf pos magic =
 347   let str = match magic with
 348     | POSIX_FORMAT | GNU_FORMAT -> "ustar\00000"
 349     | OLDGNU_FORMAT -> "ustar  \0000"
 350     | V7_FORMAT -> "      \000"
 351   in
 352     String.blit str 0 buf pos 8
 353
 354 let typeflag_to_char = function
 355   | REGULAR -> '0'
 356   | LINK -> '1'
 357   | SYMLINK -> '2'
 358   | CHRSPEC -> '3'
 359   | BLKSPEC -> '4'
 360   | DIRECTORY -> '5'
 361   | FIFO -> '6'
 362   | CONTIGIOUS -> '7'
 363   | DUMPDIR -> 'D'
 364   | LONGLINK -> 'K'
 365   | LONGNAME -> 'L'
 366   | MULTIVOL -> 'M'
 367   | NAMES -> 'N'
 368   | SPARSE -> raise (Error "Sparse files aren't supported for output")
 369   | VOLHDR -> 'V'
 370
 371 let isdigit = function '0' .. '9' -> true | _ -> false
 372
 373 let write_oldgnu_header t buf =
 374   let ext = match t.t_gnu with
 375     | Some e -> e
 376     | None -> raise (Error "OLDGNU_FORMAT record without t_gnu field set") in
 377     write_int32 buf 345 ext.t_atime;
 378     write_int32 buf 356 ext.t_ctime;
 379     write_int32 buf 369 ext.t_offset;
 380     write_int32 buf 483 ext.t_realsize
 381
 382 let write_gnu_header t buf =
 383   let ext = match t.t_gnu with
 384     | Some e -> e
 385     | None -> raise (Error "GNU_FORMAT record without t_gnu field set") in
 386     write_int32 buf 0 ext.t_atime;
 387     write_int32 buf 12 ext.t_ctime;
 388     write_int32 buf 24 ext.t_offset;
 389     write_int32 buf 36 ext.t_realsize
 390
 391 let output t head body =
 392   let size = String.length body in
 393   let buf = String.copy empty_block in
 394     write_str buf 0 100 head.t_name;
 395     write_num8 buf 100 head.t_mode;
 396     write_num8 buf 108 head.t_uid;
 397     write_num8 buf 116 head.t_gid;
 398     write_num12 buf 124 size;
 399     write_int32 buf 136 head.t_mtime;
 400     buf.[156] <- typeflag_to_char head.t_typeflag;
 401     write_str buf 157 100 head.t_linkname;
 402     write_magic buf 257 head.t_format;
 403     write_str buf 265 32 head.t_uname;
 404     write_str buf 297 32 head.t_gname;
 405     write_num8 buf 329 head.t_devmajor;
 406     write_num8 buf 337 head.t_devminor;
 407     write_str buf 345 155 head.t_prefix;
 408     if head.t_format = OLDGNU_FORMAT then
 409       write_oldgnu_header head buf;
 410     let chksum = compute_chksum buf in
 411       write_padded_num buf 148 chksum;
 412       t.ochan#output buf 0 blocksize;
 413       if head.t_format = GNU_FORMAT && isdigit buf.[156] then begin
 414         let buf2 = String.copy empty_block in
 415           write_gnu_header head buf2;
 416           t.ochan#output buf2 0 blocksize
 417       end;
 418       if size > 0 then begin
 419         let blocks = size / blocksize in
 420           for n = 0 to blocks do
 421             let pos = n * blocksize in
 422             let len =
 423               if size - pos >= blocksize then
 424                 blocksize
 425               else
 426                 size - pos in
 427               t.ochan#output body (n * 512) len;
 428           done;
 429           let align = blocksize - (size mod blocksize) in
 430             if align > 0 && align < blocksize then
 431               t.ochan#output empty_block 0 align
 432       end
 433
 434 let flush t =
 435   t.ochan#output empty_block 0 blocksize;
 436   t.ochan#flush ()
 437
 438 let close_out t =
 439   flush t;
 440   close_out t.rawochan