src/utils/cdk/zip.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                         The CamlZip library                         *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 2001 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License.         *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id$ *)
  14
  15 (* Module [Zip]: reading and writing ZIP archives *)
  16
  17 exception Error of string * string * string
  18
  19 let read1 = input_byte
  20 let read2 ic =
  21   let lb = read1 ic in let hb = read1 ic in lb lor (hb lsl 8)
  22 let read4 ic =
  23   let lw = read2 ic in let hw = read2 ic in
  24   Int32.logor (Int32.of_int lw) (Int32.shift_left (Int32.of_int hw) 16)
  25 let read4_int ic =
  26   let lw = read2 ic in let hw = read2 ic in
  27   if hw > max_int lsr 16 then raise (Error("", "", "32-bit data too large"));
  28   lw lor (hw lsl 16)
  29 let readstring ic n =
  30   let s = String.create n in
  31   really_input ic s 0 n; s
  32
  33 let write1 = output_byte
  34 let write2 oc n =
  35   write1 oc n; write1 oc (n lsr 8)
  36 let write4 oc n =
  37   write2 oc (Int32.to_int n);
  38   write2 oc (Int32.to_int (Int32.shift_right_logical n 16))
  39 let write4_int oc n =
  40   write2 oc n;
  41   write2 oc (n lsr 16)
  42 let writestring oc s =
  43   output oc s 0 (String.length s)
  44
  45 type compression_method = Stored | Deflated
  46
  47 type entry =
  48   { filename: string;
  49     extra: string;
  50     comment: string;
  51     methd: compression_method;
  52     mtime: float;
  53     crc: int32;
  54     uncompressed_size: int;
  55     compressed_size: int;
  56     is_directory: bool;
  57     file_offset: int64 }
  58
  59 type in_file =
  60   { if_filename: string;
  61     if_channel: Pervasives.in_channel;
  62     if_entries: entry list;
  63     if_directory: (string, entry) Hashtbl.t;
  64     if_comment: string }
  65
  66 let entries ifile = ifile.if_entries
  67 let comment ifile = ifile.if_comment
  68
  69 type out_file =
  70   { of_filename: string;
  71     of_channel: Pervasives.out_channel;
  72     mutable of_entries: entry list;
  73     of_comment: string }
  74
  75 exception Error of string * string * string
  76
  77 (* Return the position of the last occurrence of s1 in s2, or -1 if not
  78    found. *)
  79
  80 let strrstr pattern buf ofs len =
  81   let rec search i j =
  82     if i < ofs then -1
  83     else if j >= String.length pattern then i
  84     else if pattern.[j] = buf.[i + j] then search i (j+1)
  85     else search (i-1) 0
  86   in search (ofs + len - String.length pattern) 0
  87
  88 (* Determine if a file name is a directory (ends with /) *)
  89
  90 let filename_is_directory name =
  91   String.length name > 0 && name.[String.length name - 1] = '/'
  92
  93 (* Convert between Unix dates and DOS dates *)
  94
  95 let unixtime_of_dostime time date =
  96   fst(Unix.mktime
  97         { Unix.tm_sec = (time lsl 1) land 0x3e;
  98           Unix.tm_min = (time lsr 5) land 0x3f;
  99           Unix.tm_hour = (time lsr 11) land 0x1f;
 100           Unix.tm_mday = date land 0x1f;
 101           Unix.tm_mon = ((date lsr 5) land 0xf) - 1;
 102           Unix.tm_year = ((date lsr 9) land 0x7f) + 80;
 103           Unix.tm_wday = 0;
 104           Unix.tm_yday = 0;
 105           Unix.tm_isdst = false })
 106
 107 let dostime_of_unixtime t =
 108   let tm = Unix.localtime t in
 109   (tm.Unix.tm_sec lsr 1
 110      + (tm.Unix.tm_min lsl 5)
 111      + (tm.Unix.tm_hour lsl 11),
 112    tm.Unix.tm_mday
 113      + (tm.Unix.tm_mon + 1) lsl 5
 114      + (tm.Unix.tm_year - 80) lsl 9)
 115
 116 (* Read end of central directory record *)
 117
 118 let read_ecd filename ic =
 119   let buf = String.create 256 in
 120   let filelen = in_channel_length ic in
 121   let rec find_ecd pos len =
 122     (* On input, bytes 0 ... len - 1 of buf reflect what is at pos in ic *)
 123     if pos <= 0 || filelen - pos >= 0x10000 then
 124       raise (Error(filename, "",
 125                    "end of central directory not found, not a ZIP file"));
 126     let toread = min pos 128 in
 127     (* Make room for "toread" extra bytes, and read them *)
 128     String.blit buf 0 buf toread (256 - toread);
 129     let newpos = pos - toread in
 130     seek_in ic newpos;
 131     really_input ic buf 0 toread;
 132     let newlen = min (toread + len) 256 in
 133     (* Search for magic number *)
 134     let ofs = strrstr "PK\005\006" buf 0 newlen in
 135     if ofs < 0 || newlen < 22 ||
 136        (let comment_len =
 137           Char.code buf.[ofs + 20] lor (Char.code buf.[ofs + 21] lsl 8) in
 138         newpos + ofs + 22 + comment_len <> filelen) then
 139       find_ecd newpos newlen
 140     else
 141       newpos + ofs in
 142   seek_in ic (find_ecd filelen 0);
 143   let magic = read4 ic in
 144   let disk_no = read2 ic in
 145   let cd_disk_no = read2 ic in
 146   let _disk_entries = read2 ic in
 147   let cd_entries = read2 ic in
 148   let cd_size = read4 ic in
 149   let cd_offset = read4 ic in
 150   let comment_len = read2 ic in
 151   let comment = readstring ic comment_len in
 152   assert (magic = Int32.of_int 0x06054b50);
 153   if disk_no <> 0 || cd_disk_no <> 0 then
 154     raise (Error(filename, "", "multi-disk ZIP files not supported"));
 155   (cd_entries, cd_size, cd_offset, comment)
 156
 157 (* Read central directory *)
 158
 159 let read_cd filename ic cd_entries cd_offset cd_bound =
 160   let cd_bound = Int64.of_int32 cd_bound in
 161   try
 162     LargeFile.seek_in ic (Int64.of_int32 cd_offset);
 163     let e = ref [] in
 164     let entrycnt = ref 0 in
 165     while (LargeFile.pos_in ic < cd_bound) do
 166       incr entrycnt;
 167       let magic = read4 ic in
 168       let _version_made_by = read2 ic in
 169       let _version_needed = read2 ic in
 170       let flags = read2 ic in
 171       let methd = read2 ic in
 172       let lastmod_time = read2 ic in
 173       let lastmod_date = read2 ic in
 174       let crc = read4 ic in
 175       let compr_size = read4_int ic in
 176       let uncompr_size = read4_int ic in
 177       let name_len = read2 ic in
 178       let extra_len = read2 ic in
 179       let comment_len = read2 ic in
 180       let _disk_number = read2 ic in
 181       let _internal_attr = read2 ic in
 182       let _external_attr = read4 ic in
 183       let header_offset = Int64.of_int32(read4 ic) in
 184       let name = readstring ic name_len in
 185       let extra = readstring ic extra_len in
 186       let comment = readstring ic comment_len in
 187       if magic <> Int32.of_int 0x02014b50 then
 188         raise (Error(filename, name,
 189                      "wrong file header in central directory"));
 190       if flags land 1 <> 0 then
 191         raise (Error(filename, name, "encrypted entries not supported"));
 192
 193       e := { filename = name;
 194              extra = extra;
 195              comment = comment;
 196              methd = (match methd with
 197                          0 -> Stored
 198                        | 8 -> Deflated
 199                        | _ -> raise (Error(filename, name,
 200                                            "unknown compression method")));
 201              mtime = unixtime_of_dostime lastmod_time lastmod_date;
 202              crc = crc;
 203              uncompressed_size = uncompr_size;
 204              compressed_size = compr_size;
 205              is_directory = filename_is_directory name;
 206              file_offset = header_offset
 207            } :: !e
 208     done;
 209     assert((cd_bound = (LargeFile.pos_in ic)) &&
 210            (cd_entries = 65535 || !entrycnt = cd_entries));
 211     List.rev !e
 212   with End_of_file ->
 213     raise (Error(filename, "", "end-of-file while reading central directory"))
 214
 215 (* Open a ZIP file for reading *)
 216
 217 let open_in filename =
 218   let ic = Pervasives.open_in_bin filename in
 219   let (cd_entries, cd_size, cd_offset, cd_comment) = read_ecd filename ic in
 220   let entries =
 221     read_cd filename ic cd_entries cd_offset (Int32.add cd_offset cd_size) in
 222   let dir = Hashtbl.create (cd_entries / 3) in
 223   List.iter (fun e -> Hashtbl.add dir e.filename e) entries;
 224   { if_filename = filename;
 225     if_channel = ic;
 226     if_entries = entries;
 227     if_directory = dir;
 228     if_comment = cd_comment }
 229
 230 (* Close a ZIP file opened for reading *)
 231
 232 let close_in ifile =
 233   Pervasives.close_in ifile.if_channel
 234
 235 (* Return the info associated with an entry *)
 236
 237 let find_entry ifile name =
 238   Hashtbl.find ifile.if_directory name
 239
 240 (* Position on an entry *)
 241
 242 let goto_entry ifile e =
 243   try
 244     let ic = ifile.if_channel in
 245     LargeFile.seek_in ic e.file_offset;
 246     let magic = read4 ic in
 247     let _version_needed = read2 ic in
 248     let _flags = read2 ic in
 249     let _methd = read2 ic in
 250     let _lastmod_time = read2 ic in
 251     let _lastmod_date = read2 ic in
 252     let _crc = read4 ic in
 253     let _compr_size = read4_int ic in
 254     let _uncompr_size = read4_int ic in
 255     let filename_len = read2 ic in
 256     let extra_len = read2 ic in
 257     if magic <> Int32.of_int 0x04034b50 then
 258        raise (Error(ifile.if_filename, e.filename, "wrong local file header"));
 259     (* Could validate information read against directory entry, but
 260        what the heck *)
 261     LargeFile.seek_in ifile.if_channel
 262       (Int64.add e.file_offset (Int64.of_int (30 + filename_len + extra_len)))
 263   with End_of_file ->
 264     raise (Error(ifile.if_filename, e.filename, "truncated local file header"))
 265
 266 (* Read the contents of an entry as a string *)
 267
 268 let read_entry ifile e =
 269   try
 270     goto_entry ifile e;
 271     let res = String.create e.uncompressed_size in
 272     match e.methd with
 273       Stored ->
 274         if e.compressed_size <> e.uncompressed_size then
 275           raise (Error(ifile.if_filename, e.filename,
 276                        "wrong size for stored entry"));
 277         really_input ifile.if_channel res 0 e.uncompressed_size;
 278         res
 279     | Deflated ->
 280         let in_avail = ref e.compressed_size in
 281         let out_pos = ref 0 in
 282         begin try
 283           Zlib.uncompress ~header:false
 284             (fun buf ->
 285               let read = input ifile.if_channel buf 0
 286                                (min !in_avail (String.length buf)) in
 287               in_avail := !in_avail - read;
 288               read)
 289             (fun buf len ->
 290               if !out_pos + len > String.length res then
 291                 raise (Error(ifile.if_filename, e.filename,
 292                              "wrong size for deflated entry (too much data)"));
 293               String.blit buf 0 res !out_pos len;
 294               out_pos := !out_pos + len)
 295         with Zlib.Error(_, _) ->
 296           raise (Error(ifile.if_filename, e.filename, "decompression error"))
 297         end;
 298         if !out_pos <> String.length res then
 299           raise (Error(ifile.if_filename, e.filename,
 300                        "wrong size for deflated entry (not enough data)"));
 301         let crc = Zlib.update_crc Int32.zero res 0 (String.length res) in
 302         if crc <> e.crc then
 303           raise (Error(ifile.if_filename, e.filename, "CRC mismatch"));
 304         res
 305   with End_of_file ->
 306     raise (Error(ifile.if_filename, e.filename, "truncated data"))
 307
 308 (* Write the contents of an entry into an out channel *)
 309
 310 let copy_entry_to_channel ifile e oc =
 311   try
 312     goto_entry ifile e;
 313     match e.methd with
 314       Stored ->
 315         if e.compressed_size <> e.uncompressed_size then
 316           raise (Error(ifile.if_filename, e.filename,
 317                        "wrong size for stored entry"));
 318         let buf = String.create 4096 in
 319         let rec copy n =
 320           if n > 0 then begin
 321             let r = input ifile.if_channel buf 0 (min n (String.length buf)) in
 322             output oc buf 0 r;
 323             copy (n - r)
 324           end in
 325         copy e.uncompressed_size
 326     | Deflated ->
 327         let in_avail = ref e.compressed_size in
 328         let crc = ref Int32.zero in
 329         begin try
 330           Zlib.uncompress ~header:false
 331             (fun buf ->
 332               let read = input ifile.if_channel buf 0
 333                                (min !in_avail (String.length buf)) in
 334               in_avail := !in_avail - read;
 335               read)
 336             (fun buf len ->
 337               output oc buf 0 len;
 338               crc := Zlib.update_crc !crc buf 0 len)
 339         with Zlib.Error(_, _) ->
 340           raise (Error(ifile.if_filename, e.filename, "decompression error"))
 341         end;
 342         if !crc <> e.crc then
 343           raise (Error(ifile.if_filename, e.filename, "CRC mismatch"))
 344   with End_of_file ->
 345     raise (Error(ifile.if_filename, e.filename, "truncated data"))
 346
 347 (* Write the contents of an entry to a file *)
 348
 349 let copy_entry_to_file ifile e outfilename =
 350   let oc = open_out_bin outfilename in
 351   try
 352     copy_entry_to_channel ifile e oc;
 353     close_out oc;
 354     begin try
 355       Unix.utimes outfilename e.mtime e.mtime
 356     with Unix.Unix_error(_, _, _) | Invalid_argument _ -> ()
 357     end
 358   with x ->
 359     close_out oc;
 360     Sys.remove outfilename;
 361     raise x
 362
 363 (* Open a ZIP file for writing *)
 364
 365 let open_out ?(comment = "") filename =
 366   if String.length comment >= 0x10000 then
 367     raise(Error(filename, "", "comment too long"));
 368   { of_filename = filename;
 369     of_channel = Pervasives.open_out_bin filename;
 370     of_entries = [];
 371     of_comment = comment }
 372
 373 (* Close a ZIP file for writing.  Add central directory. *)
 374
 375 let write_directory_entry oc e =
 376   write4 oc (Int32.of_int 0x02014b50);  (* signature *)
 377   let version = match e.methd with Stored -> 10 | Deflated -> 20 in
 378   write2 oc version;                    (* version made by *)
 379   write2 oc version;                    (* version needed to extract *)
 380   write2 oc 8;                          (* flags *)
 381   write2 oc (match e.methd with Stored -> 0 | Deflated -> 8); (* method *)
 382   let (time, date) = dostime_of_unixtime e.mtime in
 383   write2 oc time;                       (* last mod time *)
 384   write2 oc date;                       (* last mod date *)
 385   write4 oc e.crc;                      (* CRC32 *)
 386   write4_int oc e.compressed_size;      (* compressed size *)
 387   write4_int oc e.uncompressed_size;    (* uncompressed size *)
 388   write2 oc (String.length e.filename); (* filename length *)
 389   write2 oc (String.length e.extra);    (* extra length *)
 390   write2 oc (String.length e.comment);  (* comment length *)
 391   write2 oc 0;                          (* disk number start *)
 392   write2 oc 0;                          (* internal attributes *)
 393   write4_int oc 0;                      (* external attributes *)
 394   write4 oc (Int64.to_int32 e.file_offset); (* offset of local header *)
 395   writestring oc e.filename;            (* filename *)
 396   writestring oc e.extra;               (* extra info *)
 397   writestring oc e.comment              (* file comment *)
 398
 399 let close_out ofile =
 400   let oc = ofile.of_channel in
 401   let start_cd = pos_out oc in
 402   List.iter (write_directory_entry oc) (List.rev ofile.of_entries);
 403   let cd_size = pos_out oc - start_cd in
 404   let num_entries = List.length ofile.of_entries in
 405   if num_entries >= 0x10000 then
 406     raise(Error(ofile.of_filename, "", "too many entries"));
 407   write4 oc (Int32.of_int 0x06054b50);  (* signature *)
 408   write2 oc 0;                          (* disk number *)
 409   write2 oc 0;                          (* number of disk with central dir *)
 410   write2 oc num_entries;                (* # entries in this disk *)
 411   write2 oc num_entries;                (* # entries in central dir *)
 412   write4_int oc cd_size;                (* size of central dir *)
 413   write4_int oc start_cd;               (* offset of central dir *)
 414   write2 oc (String.length ofile.of_comment); (* length of comment *)
 415   writestring oc ofile.of_comment;         (* comment *)
 416   Pervasives.close_out oc
 417
 418 (* Write a local file header and return the corresponding entry *)
 419
 420 let add_entry_header ofile extra comment level mtime filename =
 421   if level < 0 || level > 9 then
 422     raise(Error(ofile.of_filename, filename, "wrong compression level"));
 423   if String.length filename >= 0x10000 then
 424     raise(Error(ofile.of_filename, filename, "filename too long"));
 425   if String.length extra >= 0x10000 then
 426     raise(Error(ofile.of_filename, filename, "extra data too long"));
 427   if String.length comment >= 0x10000 then
 428     raise(Error(ofile.of_filename, filename, "comment too long"));
 429   let oc = ofile.of_channel in
 430   let pos = LargeFile.pos_out oc in
 431   write4 oc (Int32.of_int 0x04034b50);  (* signature *)
 432   let version = if level = 0 then 10 else 20 in
 433   write2 oc version;                    (* version needed to extract *)
 434   write2 oc 8;                          (* flags *)
 435   write2 oc (if level = 0 then 0 else 8); (* method *)
 436   let (time, date) = dostime_of_unixtime mtime in
 437   write2 oc time;                       (* last mod time *)
 438   write2 oc date;                       (* last mod date *)
 439   write4 oc Int32.zero;                 (* CRC32 - to be filled later *)
 440   write4_int oc 0;                      (* compressed size - later *)
 441   write4_int oc 0;                      (* uncompressed size - later *)
 442   write2 oc (String.length filename);   (* filename length *)
 443   write2 oc (String.length extra);      (* extra length *)
 444   writestring oc filename;              (* filename *)
 445   writestring oc extra;                 (* extra info *)
 446   { filename = filename;
 447     extra = extra;
 448     comment = comment;
 449     methd = (if level = 0 then Stored else Deflated);
 450     mtime = mtime;
 451     crc = Int32.zero;
 452     uncompressed_size = 0;
 453     compressed_size = 0;
 454     is_directory = filename_is_directory filename;
 455     file_offset = pos }
 456
 457 (* Write a data descriptor and update the entry *)
 458
 459 let add_data_descriptor ofile crc compr_size uncompr_size entry =
 460   let oc = ofile.of_channel in
 461   write4 oc (Int32.of_int 0x08074b50);  (* signature *)
 462   write4 oc crc;                        (* CRC *)
 463   write4_int oc compr_size;             (* compressed size *)
 464   write4_int oc uncompr_size;           (* uncompressed size *)
 465   { entry with crc = crc;
 466                uncompressed_size = uncompr_size;
 467                compressed_size = compr_size }
 468
 469 (* Add an entry with the contents of a string *)
 470
 471 let add_entry data ofile ?(extra = "") ?(comment = "")
 472                          ?(level = 6) ?(mtime = Unix.time()) name =
 473   let e = add_entry_header ofile extra comment level mtime name in
 474   let crc = Zlib.update_crc Int32.zero data 0 (String.length data) in
 475   let compr_size =
 476     match level with
 477       0 ->
 478         output ofile.of_channel data 0 (String.length data);
 479         String.length data
 480     | _ ->
 481         let in_pos = ref 0 in
 482         let out_pos = ref 0 in
 483         try
 484           Zlib.compress ~header:false
 485             (fun buf ->
 486                let n = min (String.length data - !in_pos)
 487                            (String.length buf) in
 488                String.blit data !in_pos buf 0 n;
 489                in_pos := !in_pos + n;
 490                n)
 491             (fun buf n ->
 492                 output ofile.of_channel buf 0 n;
 493                 out_pos := !out_pos + n);
 494           !out_pos
 495         with Zlib.Error(_, _) ->
 496           raise (Error(ofile.of_filename, name, "compression error")) in
 497   let e' = add_data_descriptor ofile crc compr_size (String.length data) e in
 498   ofile.of_entries <- e' :: ofile.of_entries
 499
 500 (* Add an entry with the contents of an in channel *)
 501
 502 let copy_channel_to_entry ic ofile ?(extra = "") ?(comment = "")
 503                                    ?(level = 6) ?(mtime = Unix.time()) name =
 504   let e = add_entry_header ofile extra comment level mtime name in
 505   let crc = ref Int32.zero in
 506   let (compr_size, uncompr_size) =
 507     match level with
 508       0 ->
 509         let buf = String.create 4096 in
 510         let rec copy sz =
 511           let r = input ic buf 0 (String.length buf) in
 512           if r = 0 then sz else begin
 513             crc := Zlib.update_crc !crc buf 0 r;
 514             output ofile.of_channel buf 0 r;
 515             copy (sz + r)
 516           end in
 517         let size = copy 0 in
 518         (size, size)
 519     | _ ->
 520         let in_pos = ref 0 in
 521         let out_pos = ref 0 in
 522         try
 523           Zlib.compress ~header:false
 524             (fun buf ->
 525                let r = input ic buf 0 (String.length buf) in
 526                crc := Zlib.update_crc !crc buf 0 r;
 527                in_pos := !in_pos + r;
 528                r)
 529             (fun buf n ->
 530                output ofile.of_channel buf 0 n;
 531                out_pos := !out_pos + n);
 532           (!out_pos, !in_pos)
 533         with Zlib.Error(_, _) ->
 534           raise (Error(ofile.of_filename, name, "compression error")) in
 535   let e' = add_data_descriptor ofile !crc compr_size uncompr_size e in
 536   ofile.of_entries <- e' :: ofile.of_entries
 537
 538 (* Add an entry with the contents of a file *)
 539
 540 let copy_file_to_entry infilename ofile ?(extra = "") ?(comment = "")
 541                                         ?(level = 6) ?mtime name =
 542   let ic = open_in_bin infilename in
 543   let mtime' =
 544     match mtime with
 545       Some t -> mtime
 546     | None ->
 547         try Some((Unix.LargeFile.stat infilename).Unix.LargeFile.st_mtime)
 548         with Unix.Unix_error(_,_,_) -> None in
 549   try
 550     copy_channel_to_entry ic ofile ~extra ~comment ~level ?mtime:mtime' name;
 551     Pervasives.close_in ic
 552   with x ->
 553     Pervasives.close_in ic; raise x