Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 134 lines (115 sloc) 4.358 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 @author Frederic Ye
20 **)
21
22 (* Same as Gzip (Libzip) but uses a string instead of a stream *)
23
24
25 exception Error of string
26
27 let buffer_size = 1024
28
29 let char_buffer = String.create 1
30
31 type out_channel =
32 { out_buffer: string;
33 mutable out_pos: int;
34 mutable out_avail: int;
35 out_stream: Zlib.stream;
36 mutable out_string: string;
37 mutable out_size: int32;
38 mutable out_crc: int32;
39 only_deflate : bool }
40
41 let output_byte oz b =
42 oz.out_string <- Printf.sprintf "%s%c" oz.out_string (Char.unsafe_chr b)
43
44 let open_out ?(level = 6) ?(only_deflate=false) () =
45 if level < 1 || level > 9 then invalid_arg "Gzip.open_out: bad level";
46 let oz = {
47 out_buffer = String.create buffer_size;
48 out_pos = 0;
49 out_avail = buffer_size;
50 out_stream = Zlib.deflate_init level false;
51 out_string = "";
52 out_size = Int32.zero;
53 out_crc = Int32.zero;
54 only_deflate = only_deflate } in
55 (* Write minimal header *)
56 if not only_deflate then (
57 output_byte oz 0x1F; (* ID1 *)
58 output_byte oz 0x8B; (* ID2 *)
59 output_byte oz 8; (* compression method *)
60 output_byte oz 0; (* flags *)
61 for i = 1 to 4 do output_byte oz 0 done; (* mtime *)
62 output_byte oz 0; (* xflags *)
63 output_byte oz 0xFF; (* OS (unknown) *)
64 );
65 oz
66
67 let rec output oz buf pos len =
68 if pos < 0 || len < 0 || pos + len > String.length buf then
69 invalid_arg "Gzip.output";
70 (* If output buffer is full, flush it *)
71 if oz.out_avail = 0 then begin
72 oz.out_string <- Printf.sprintf "%s%s" oz.out_string (String.sub oz.out_buffer 0 oz.out_pos);
73 oz.out_pos <- 0;
74 oz.out_avail <- String.length oz.out_buffer
75 end;
76 let (_, used_in, used_out) =
77 try
78 Zlib.deflate oz.out_stream buf pos len
79 oz.out_buffer oz.out_pos oz.out_avail
80 Zlib.Z_NO_FLUSH
81 with Zlib.Error(_, _) ->
82 raise (Error("error during compression")) in
83 oz.out_pos <- oz.out_pos + used_out;
84 oz.out_avail <- oz.out_avail - used_out;
85 if not oz.only_deflate then (
86 oz.out_size <- Int32.add oz.out_size (Int32.of_int used_in);
87 oz.out_crc <- Zlib.update_crc oz.out_crc buf pos used_in;
88 );
89 if used_in < len then output oz buf (pos + used_in) (len - used_in)
90
91 let output_char oz c =
92 char_buffer.[0] <- c;
93 output oz char_buffer 0 1
94
95 let output_byte oz b =
96 output_char oz (Char.unsafe_chr b)
97
98 let write_int32 oz n =
99 let r = ref n in
100 for i = 1 to 4 do
101 oz.out_string <- Printf.sprintf "%s%c" oz.out_string (Char.unsafe_chr (Int32.to_int !r));
102 r := Int32.shift_right_logical !r 8
103 done
104
105 let flush oz =
106 let rec do_flush () =
107 (* If output buffer is full, flush it *)
108 if oz.out_avail = 0 then begin
109 oz.out_string <- Printf.sprintf "%s%s" oz.out_string (String.sub oz.out_buffer 0 oz.out_pos);
110 oz.out_pos <- 0;
111 oz.out_avail <- String.length oz.out_buffer
112 end;
113 let (finished, _, used_out) =
114 Zlib.deflate oz.out_stream oz.out_buffer 0 0
115 oz.out_buffer oz.out_pos oz.out_avail
116 Zlib.Z_FINISH in
117 oz.out_pos <- oz.out_pos + used_out;
118 oz.out_avail <- oz.out_avail - used_out;
119 if not finished then do_flush() in
120 do_flush();
121 (* Final data flush *)
122 if oz.out_pos > 0 then
123 oz.out_string <- Printf.sprintf "%s%s" oz.out_string (String.sub oz.out_buffer 0 oz.out_pos);
124 (* Write CRC and size *)
125 if not oz.only_deflate then (
126 write_int32 oz oz.out_crc;
127 write_int32 oz oz.out_size;
128 );
129 (* Dispose of stream *)
130 Zlib.deflate_end oz.out_stream
131
132 let close_out oz =
133 flush oz
Something went wrong with that request. Please try again.