src/utils/cdk/zlib.ml

   1 exception Error of string * string
   2
   3 let _ =
   4   Callback.register_exception "Zlib.Error" (Error("",""))
   5
   6 type stream
   7
   8 type flush_command =
   9     Z_NO_FLUSH
  10   | Z_SYNC_FLUSH
  11   | Z_FULL_FLUSH
  12   | Z_FINISH
  13
  14 external deflate_init: int -> bool -> stream = "camlzip_deflateInit"
  15 external deflate:
  16   stream -> string -> int -> int -> string -> int -> int -> flush_command
  17          -> bool * int * int
  18   = "camlzip_deflate_bytecode" "camlzip_deflate"
  19 external deflate_end: stream -> unit = "camlzip_deflateEnd"
  20
  21 external inflate_init: bool -> stream = "camlzip_inflateInit"
  22 external inflate:
  23   stream -> string -> int -> int -> string -> int -> int -> flush_command
  24          -> bool * int * int
  25   = "camlzip_inflate_bytecode" "camlzip_inflate"
  26 external inflate_end: stream -> unit = "camlzip_inflateEnd"
  27
  28 external update_crc: int32 -> string -> int -> int -> int32
  29                    = "camlzip_update_crc32"
  30
  31 external zlib_version : unit -> string = "camlzip_zlibversion"
  32
  33 let zlib_version_num () =
  34   begin
  35     try
  36       zlib_version ()
  37     with e -> ""
  38   end
  39
  40 let buffer_size = 1024
  41
  42 let compress ?(level = 6) ?(header = true) refill flush =
  43   let inbuf = String.create buffer_size
  44   and outbuf = String.create buffer_size in
  45   let zs = deflate_init level header in
  46   let rec compr inpos inavail =
  47     if inavail = 0 then begin
  48       let incount = refill inbuf in
  49       if incount = 0 then compr_finish() else compr 0 incount
  50     end else begin
  51       let (_, used_in, used_out) =
  52         deflate zs inbuf inpos inavail outbuf 0 buffer_size Z_NO_FLUSH in
  53       flush outbuf used_out;
  54       compr (inpos + used_in) (inavail - used_in)
  55     end
  56   and compr_finish () =
  57     let (finished, _, used_out) =
  58        deflate zs inbuf 0 0 outbuf 0 buffer_size Z_FINISH in
  59     flush outbuf used_out;
  60     if not finished then compr_finish()
  61   in
  62     compr 0 0;
  63     deflate_end zs
  64
  65 let grow_buffer s =
  66   let s' = String.create (2 * String.length s) in
  67   String.blit s 0 s' 0 (String.length s);
  68   s'
  69
  70 let compress_string ?(level = 6) inbuf =
  71   let zs = deflate_init level true in
  72   let rec compr inpos outbuf outpos =
  73     let inavail = String.length inbuf - inpos in
  74     let outavail = String.length outbuf - outpos in
  75     if outavail = 0
  76     then compr inpos (grow_buffer outbuf) outpos
  77     else begin
  78       let (finished, used_in, used_out) =
  79         deflate zs inbuf inpos inavail outbuf outpos outavail
  80                    (if inavail = 0 then Z_FINISH else Z_NO_FLUSH) in
  81       if finished then
  82         String.sub outbuf 0 (outpos + used_out)
  83       else
  84         compr (inpos + used_in) outbuf (outpos + used_out)
  85     end in
  86   let res = compr 0 (String.create (String.length inbuf)) 0 in
  87   deflate_end zs;
  88   res
  89
  90 (* header info from camlzip/gpl *)
  91 let gzip_string ?(level = 6) inbuf =
  92   if String.length inbuf <= 0 then "" else
  93   begin
  94   let zs = deflate_init level false in
  95   let out_crc = ref Int32.zero in
  96   let rec compr inpos outbuf outpos =
  97     let inavail = String.length inbuf - inpos in
  98     let outavail = String.length outbuf - outpos in
  99     if outavail = 0
 100     then compr inpos (grow_buffer outbuf) outpos
 101     else begin
 102       let (finished, used_in, used_out) =
 103         deflate zs inbuf inpos inavail outbuf outpos outavail
 104                    (if inavail = 0 then Z_FINISH else Z_NO_FLUSH) in
 105          out_crc := update_crc !out_crc inbuf inpos used_in;
 106       if finished then
 107         String.sub outbuf 0 (outpos + used_out)
 108       else
 109         compr (inpos + used_in) outbuf (outpos + used_out)
 110     end in
 111   let res = compr 0 (String.create (String.length inbuf)) 0 in
 112   deflate_end zs;
 113   let buf = Buffer.create (18 + String.length res) in
 114   let write_int wbuf n =
 115     Buffer.add_char wbuf (char_of_int n)
 116   in
 117   let write_int32 wbuf n =
 118     let r = ref n in
 119     for i = 1 to 4 do
 120       Buffer.add_char wbuf (char_of_int (Int32.to_int (Int32.logand !r 0xffl)));
 121       r := Int32.shift_right_logical !r 8
 122     done
 123   in
 124   write_int buf 0x1F;
 125   write_int buf 0x8B;
 126   write_int buf 8;
 127   write_int buf 0;
 128   for i = 1 to 4 do write_int buf 0 done;
 129   write_int buf 0;
 130   write_int buf 0xFF;
 131   Buffer.add_string buf res;
 132   write_int32 buf !out_crc;
 133   write_int32 buf (Int32.of_int (String.length inbuf));
 134   Buffer.contents buf
 135   end
 136
 137 let uncompress ?(header = true) refill flush =
 138   let inbuf = String.create buffer_size
 139   and outbuf = String.create buffer_size in
 140   let zs = inflate_init header in
 141   let rec uncompr inpos inavail =
 142     if inavail = 0 then begin
 143       let incount = refill inbuf in
 144       if incount = 0 then uncompr_finish true else uncompr 0 incount
 145     end else begin
 146       let (finished, used_in, used_out) =
 147         inflate zs inbuf inpos inavail outbuf 0 buffer_size Z_SYNC_FLUSH in
 148       flush outbuf used_out;
 149       if not finished then uncompr (inpos + used_in) (inavail - used_in)
 150     end
 151   and uncompr_finish first_finish =
 152     (* Gotcha: if there is no header, inflate requires an extra "dummy" byte
 153        after the compressed stream in order to complete decompression
 154        and return finished = true. *)
 155     let dummy_byte = if first_finish && not header then 1 else 0 in
 156     let (finished, _, used_out) =
 157        inflate zs inbuf 0 dummy_byte outbuf 0 buffer_size Z_SYNC_FLUSH in
 158     flush outbuf used_out;
 159     if not finished then uncompr_finish false
 160   in
 161     uncompr 0 0;
 162     inflate_end zs
 163
 164 let uncompress_string2 inbuf =
 165   let zs = inflate_init true in
 166   let rec uncompr inpos outbuf outpos =
 167     let inavail = String.length inbuf - inpos in
 168     let outavail = String.length outbuf - outpos in
 169     if outavail = 0
 170     then uncompr inpos (grow_buffer outbuf) outpos
 171     else begin
 172       let (finished, used_in, used_out) =
 173         inflate zs inbuf inpos inavail outbuf outpos outavail Z_SYNC_FLUSH in
 174       if finished then
 175         String.sub outbuf 0 (outpos + used_out)
 176       else
 177         uncompr (inpos + used_in) outbuf (outpos + used_out)
 178     end in
 179   let res = uncompr 0 (String.create (2 * String.length inbuf)) 0 in
 180   inflate_end zs;
 181   res
 182
 183 let uncompress_string s =
 184   let buf = Buffer.create (2 * String.length s) in
 185   let pos = ref 0 in
 186   let len = String.length s in
 187   uncompress ~header: true (fun b ->
 188       let n = min (String.length b) (len - !pos) in
 189       if n < 1 then 0 else begin
 190       String.blit s !pos b 0 n;
 191       pos := !pos + n;
 192       n end
 193   ) (fun s len -> Buffer.add_string buf (String.sub s 0 len));
 194   Buffer.contents buf
 195