1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
exception Error of string * string
let _ =
Callback.register_exception "Zlib.Error" (Error("",""))
type stream
type flush_command =
Z_NO_FLUSH
| Z_SYNC_FLUSH
| Z_FULL_FLUSH
| Z_FINISH
external deflate_init: int -> bool -> stream = "camlzip_deflateInit"
external deflate:
stream -> bytes -> int -> int -> bytes -> int -> int -> flush_command
-> bool * int * int
= "camlzip_deflate_bytecode" "camlzip_deflate"
external deflate_string:
stream -> string -> int -> int -> bytes -> int -> int -> flush_command
-> bool * int * int
= "camlzip_deflate_bytecode" "camlzip_deflate"
external deflate_end: stream -> unit = "camlzip_deflateEnd"
external inflate_init: bool -> stream = "camlzip_inflateInit"
external inflate:
stream -> bytes -> int -> int -> bytes -> int -> int -> flush_command
-> bool * int * int
= "camlzip_inflate_bytecode" "camlzip_inflate"
external inflate_string:
stream -> string -> int -> int -> bytes -> int -> int -> flush_command
-> bool * int * int
= "camlzip_inflate_bytecode" "camlzip_inflate"
external inflate_end: stream -> unit = "camlzip_inflateEnd"
external update_crc: int32 -> bytes -> int -> int -> int32
= "camlzip_update_crc32"
external update_crc_string: int32 -> string -> int -> int -> int32
= "camlzip_update_crc32"
let buffer_size = 1024
let compress ?(level = 6) ?( = true) refill flush =
let inbuf = Bytes.create buffer_size
and outbuf = Bytes.create buffer_size in
let zs = deflate_init level header in
let rec compr inpos inavail =
if inavail = 0 then begin
let incount = refill inbuf in
if incount = 0 then compr_finish() else compr 0 incount
end else begin
let (_, used_in, used_out) =
deflate zs inbuf inpos inavail outbuf 0 buffer_size Z_NO_FLUSH in
flush outbuf used_out;
compr (inpos + used_in) (inavail - used_in)
end
and compr_finish () =
let (finished, _, used_out) =
deflate zs inbuf 0 0 outbuf 0 buffer_size Z_FINISH in
flush outbuf used_out;
if not finished then compr_finish()
in
compr 0 0;
deflate_end zs
let compress_direct ?(level = 6) ?( = true) flush =
let outbuf = Bytes.create buffer_size in
let zs = deflate_init level header in
let rec compr inbuf inpos inavail =
if inavail = 0 then ()
else begin
let (_, used_in, used_out) =
deflate zs inbuf inpos inavail outbuf 0 buffer_size Z_NO_FLUSH in
flush outbuf used_out;
compr inbuf (inpos + used_in) (inavail - used_in)
end
and compr_finish () =
let (finished, _, used_out) =
deflate zs (Bytes.unsafe_of_string "") 0 0
outbuf 0 buffer_size Z_FINISH in
flush outbuf used_out;
if not finished then compr_finish()
else deflate_end zs
in
compr, compr_finish
let uncompress ?( = true) refill flush =
let inbuf = Bytes.create buffer_size
and outbuf = Bytes.create buffer_size in
let zs = inflate_init header in
let rec uncompr inpos inavail =
if inavail = 0 then begin
let incount = refill inbuf in
if incount = 0 then uncompr_finish 0 else uncompr 0 incount
end else begin
let (finished, used_in, used_out) =
inflate zs inbuf inpos inavail outbuf 0 buffer_size Z_SYNC_FLUSH in
flush outbuf used_out;
if not finished then uncompr (inpos + used_in) (inavail - used_in)
end
and uncompr_finish num_round =
let dummy_byte = if num_round = 0 && not header then 1 else 0 in
let (finished, _, used_out) =
inflate zs inbuf 0 dummy_byte outbuf 0 buffer_size Z_SYNC_FLUSH in
flush outbuf used_out;
if finished then ()
else if used_out > 0 then uncompr_finish 1
else if num_round < 10 then uncompr_finish (num_round + 1)
else
raise(Error("Zlib.uncompress", "truncated input data"))
in
uncompr 0 0;
inflate_end zs