/pliant/util/encoding/zlib.pli
1	abstract
2	[This is Pliant zlib implementation according to RFC 1950 (deflate) and RFC 1951 (zlib)]
3	eol ; highlight "only uncompressing is implemented, and it's not yet a Pliant filesystem"
4
5	module "/pliant/language/compiler.pli"
6	module "/pliant/language/stream.pli"
7
8
9
10
11
12	type BitStream
13	field Address buffer
14	field Int size # number of bits
15	field Int offset # in bits
16	field Pointer:Stream stream
17
18	method b bind s
19	arg_rw BitStream b ; arg_rw Stream s
20	b stream :> s
21	b size := 0
22	b offset := 0
23
24	method b read n -> v
25	arg_rw BitStream b ; arg Int n ; arg uInt v
26	if b:offset+n<=b:size
27	v := ((b:buffer translate Byte b:offset\8) map uInt) \ 2^(b:offset .and. 7) .and. (2^n-1)
28	b offset += n
29	eif b:offset=b:size
30	b:stream read_available b:buffer b:size
31	b size *= 8
32	b offset := 0
33	v := b read n
34	else
35	var Int avail := b:size-b:offset
36	v := (b read avail)+(b read n-avail)*2^avail
37
38	method b unbind
39	arg_rw BitStream b
40	var Int remain := (b:size-b:offset)\8
41	b:stream stream_read_cur := b:stream:stream_read_cur translate Byte -remain
42
43
44
45
46
47	constant huffman_max_bits 15 # Huffman codes must not have more than huffman_max_bits bits
48
49	type HuffmanData
50	void
51
52	type HuffmanNode
53	field Link:HuffmanData zero one
54
55	type HuffmanLeaf
56	field Int letter
57
58	HuffmanData maybe HuffmanNode
59	HuffmanData maybe HuffmanLeaf
60
61	type Huffman
62	field Link:HuffmanData root
63
64
65	method hd check -> ok
66	oarg HuffmanData hd ; arg CBool ok
67	if addressof:hd=null
68	ok := false
69	eif (entry_type addressof:hd)=HuffmanNode
70	var Link:HuffmanNode n :> addressof:hd omap HuffmanNode
71	ok := n:zero:check and n:one:check
72	else
73	ok := (entry_type addressof:hd)=HuffmanLeaf
74
75	method h define letter code length -> status
76	arg_rw Huffman h ; arg Int letter code length ; arg Status status
77	var (Pointer Link:HuffmanData) ptr :>> h root
78	for (var Int i) 1 length
79	if addressof:ptr=null
80	ptr :> new HuffmanNode
81	if (entry_type addressof:ptr)<>HuffmanNode
82	return failure
83	var Pointer:HuffmanNode n :> addressof:ptr map HuffmanNode
84	if (code .and. 2^(huffman_max_bits-i))<>0
85	ptr :>> n one
86	else
87	ptr :>> n zero
88	var Link:HuffmanLeaf nl :> new HuffmanLeaf
89	nl letter := letter
90	ptr :> nl
91	status := success
92
93	method h setup lengths -> status
94	arg_rw Huffman h ; arg Array:Int lengths ; arg Status status
95	for (var Int i) 0 lengths:size-1
96	if lengths:i<0 or lengths:i>huffman_max_bits
97	return failure
98	h root :> null map HuffmanData
99	var Int code := 0
100	for (var Int length) 1 huffman_max_bits
101	for (var Int letter) 0 lengths:size-1
102	if lengths:letter=length
103	h define letter code length
104	code += 2^(huffman_max_bits-length)
105	status := shunt code=2^huffman_max_bits and h:root:check success failure
106
107	method h setup_default_letters -> status
108	arg_rw Huffman h ; arg Status status
109	(var Array:Int lengths) size := 288
110	for (var Int i) 0 lengths:size-1
111	lengths i := shunt i<=143 8 i<=255 9 i<=279 7 8
112	status := h setup lengths
113
114	method h setup_default_distances -> status
115	arg_rw Huffman h ; arg Status status
116	(var Array:Int lengths) size := 32
117	for (var Int i) 0 lengths:size-1
118	lengths i := 5
119	status := h setup lengths
120
121	method h read_letter bs -> letter
122	arg Huffman h ; arg_rw BitStream bs ; arg Int letter
123	var Pointer:HuffmanData cur :> h root
124	while (entry_type addressof:cur)=HuffmanNode
125	var Pointer:HuffmanNode n :> addressof:cur map HuffmanNode
126	if (bs read 1)=1
127	cur :> n one
128	else
129	cur :> n zero
130	letter := (addressof:cur omap HuffmanLeaf) letter
131
132	method h setup_custom size encoding bs -> status
133	arg_rw Huffman h ; arg Int size ; arg Huffman encoding ; arg_rw BitStream bs ; arg Status status
134	(var Array:Int lengths) size := size
135	var Int i := 0
136	while i<lengths:size
137	var Int code := encoding read_letter bs
138	if code<16
139	lengths i := code
140	i += 1
141	eif code=16
142	var Int count := 3+(bs read 2)
143	for (var Int j) 1 count
144	lengths i := lengths i-1
145	i += 1
146	eif code=17
147	var Int count := 3+(bs read 3)
148	for (var Int j) 1 count
149	lengths i := 0
150	i += 1
151	eif code=18
152	var Int count := 11+(bs read 7)
153	for (var Int j) 1 count
154	lengths i := 0
155	i += 1
156	else
157	return failure
158	status := h setup lengths
159
160
161
162
163
164	constant deflate_bufsize 2^15
165
166	type DeflateBuffer
167	field Int start stop
168	field (Array Byte deflate_bufsize) buffer
169	field Pointer:Stream out_stream ; field Intn bytes_count
170	field Int crc_type ; field uInt alder32
171
172	function alder32_update crc buf size
173	arg_rw uInt crc ; arg Address buf ; arg Int size
174	var Int s1 := crc .and. 0FFFFh
175	var Int s2 := (crc .and. 0FFFF0000h)\2^16
176	for (var Int i) 0 size-1
177	var Int b := (buf translate Byte i) map uInt8
178	s1 := (s1+b)%65521
179	s2 := (s2+s1)%65521
180	crc := s1+(s2*2^16)
181
182	method db flush_some
183	arg_rw DeflateBuffer db
184	check db:start>=0 and db:start<=deflate_bufsize and  db:stop>=db:start and db:stop<=deflate_bufsize
185	var Int step := (min db:stop deflate_bufsize)-db:start
186	db:out_stream raw_write ((addressof db:buffer) translate Byte db:start) step
187	db start += step
188	if db:start>=deflate_bufsize
189	db start -= deflate_bufsize
190	db stop -= deflate_bufsize
191	db bytes_count += step
192
193	method db setup out_stream crc_type
194	arg_w DeflateBuffer db ; arg_rw Stream out_stream ; arg Int crc_type
195	db start := 0 ; db stop := 0 ; db bytes_count := 0
196	db out_stream :> out_stream
197	db crc_type := crc_type ; db alder32 := 1
198
199	method db terminate bytes_count crc
200	arg_rw DeflateBuffer db ; arg_w Intn bytes_count ; arg_w uInt32 crc
201	while db:start<>db:stop
202	db flush_some
203	bytes_count := db bytes_count
204	if db:crc_type=1
205	crc := db alder32
206
207	method db write adr size charbychar
208	arg_rw DeflateBuffer db ; arg Address adr ; arg Int size ; arg CBool charbychar
209	check db:start>=0 and db:start<=deflate_bufsize and  db:stop>=db:start and db:stop<=deflate_bufsize
210	var Int written := 0
211	while written<size
212	var Int step := min size-written deflate_bufsize-db:stop
213	if not charbychar
214	memory_copy (adr translate Byte written) ((addressof db:buffer) translate Byte db:stop) step
215	else
216	for (var Int i) 0 step-1
217	((addressof db:buffer) translate Byte db:stop+i) map uInt8 := (adr translate Byte written+i) map uInt8
218	if db:crc_type=1
219	alder32_update db:alder32 (adr translate Byte written) step
220	db stop += step
221	if db:stop>=deflate_bufsize
222	db flush_some
223	written += step
224
225
226	method db write adr size
227	arg_rw DeflateBuffer db ; arg Address adr ; arg Int size
228	db write adr size false
229
230	method db status -> s
231	arg DeflateBuffer db ; arg Status s
232	s := shunt db:out_stream=success success failure
233
234
235
236
237
238	function letter_length letter bs -> length
239	arg Int letter ; arg_rw BitStream bs ; arg Int length
240	if letter<=264
241	length := letter-264+10
242	eif letter<285
243	var Int extra := (letter-261)\4
244	length := 3+2^(extra+2)+(letter-261-extra*4)*2^extra+(bs read extra)
245	eif letter=285
246	length := 258
247	else
248	length := undefined
249
250	function distance distances bs -> dist
251	arg Huffman distances ; arg_rw BitStream bs ; arg Int dist
252	var uInt code := distances read_letter bs
253	if code<4
254	dist := 1+code
255	eif code<30
256	var Int extra := (code-2)\2
257	dist := 1+2^(extra+1)+(code-2-extra*2)*2^extra+(bs read extra)
258	else
259	dist := undefined
260
261
262	function deflate_uncompress src dest crc_type bytes_count crc -> status
263	arg_rw Stream src dest ; arg Int crc_type ; arg_w Intn bytes_count ; arg_w uInt32 crc ; arg Status status
264	(var BitStream bs) bind src
265	var DeflateBuffer buf ; buf setup dest crc_type
266	part deflate_one_block
267	var Int bfinal := bs read 1
268	var Int btype := bs read 2
269	if btype=0 # no compression
270	bs unbind
271	src raw_read addressof:(var uInt16_li len) uInt16:size
272	src raw_read addressof:(var uInt16_li nlen) uInt16:size
273	if nlen<>(len .xor. 0FFFFh)
274	return failure
275	while len>0
276	src read_available (var Address adr) (var Int size) len
277	buf write adr size
278	len -= size
279	bs bind src
280	eif btype=1 or btype=2 # compressed with fixed Huffman codes
281	var Huffman letters distances ; var Status status1 status2
282	if btype=1
283	status1 := letters setup_default_letters
284	status2 := distances setup_default_distances
285	eif btype=2
286	var uInt hlit := bs read 5
287	var uInt hdist := bs read 5
288	var uInt hclen := bs read 4
289	(var Array:Int lengths) size := 19
290	for (var Int i) 0 lengths:size-1
291	var Int order := shunt i<3 16+i i=3 0 i%2=1 9-i\2 6+i\2
292	if i<hclen+4
293	lengths order := bs read 3
294	else
295	lengths order := 0
296	if ((var Huffman encoding) setup lengths)=failure
297	return failure
298	status1 := letters setup_custom hlit+257 encoding bs
299	status2 := distances setup_custom hdist+1 encoding bs
300	if status1=failure or status2=failure
301	return failure
302	part deflate_one_letter
303	var Int letter := letters read_letter bs
304	if letter<256
305	var uInt8 letter8 := letter
306	buf write addressof:letter8 1
307	eif letter>256
308	var Int length := letter_length letter bs
309	var Int dist := distance distances bs
310	if length=undefined or dist=undefined
311	return failure
312	while length>0
313	var Int offset := buf:stop-dist
314	if offset<0
315	offset += deflate_bufsize
316	var Int step := min length deflate_bufsize-offset
317	buf write ((addressof buf:buffer) translate Byte offset) step dist<Int:size
318	length -= step
319	else
320	leave deflate_one_letter
321	restart deflate_one_letter
322	else # error
323	return failure
324	if bfinal=0
325	restart deflate_one_block
326	buf terminate bytes_count crc
327	bs unbind
328	status := success
329
330
331
332
333
334	function zlib_uncompress src dest -> status
335	arg_rw Stream src dest ; arg Status status
336	src raw_read addressof:(var uInt8 cmf) 1
337	var Int cm := cmf .and. 0Fh
338	var Int cinfo := (cmf .and. 0F0h)\2^4
339	src raw_read addressof:(var uInt8 flg) 1
340	var Int fdict := (cmf .and. 020h)\2^5
341	var Int flevel := (cmf .and. 0C0h)\2^6
342	if cm<>8 or cinfo<>7 or (cmf*256+flg)%31<>0
343	return failure
344	if (deflate_uncompress src dest 1 (var Intn bytes_count) (var uInt32 crc))=failure
345	return failure
346	src raw_read addressof:(var uInt32_hi alder32) uInt32:size
347	if alder32<>crc
348	console " WRONG CRC " (string (cast alder32 uInt) "radix 16") " " (string (cast crc uInt) "radix 16") eol
349	status := shunt alder32=crc success failure
350
351
352
353
354
355	type GzipHeader
356	packed
357	field uInt8 id1 id2
358	field uInt8 cm flg
359	field uInt32_li mtime
360	field uInt8 xfl os
361
362	function gzip_uncompress src dest -> status
363	arg_rw Stream src dest ; arg Status status
364	src raw_read addressof:(var GzipHeader h) GzipHeader:size
365	if h:id1<>1Fh or h:id2<>8Bh
366	return failure
367	if h:cm<>8
368	return failure
369	if (h:flg .and. 2^2)<>0 # FEXTRA
370	src raw_read addressof:(var uInt16_li xlen) 2
371	while xlen>=0 and not src:atend
372	src read_available (var Address adr) (var Int size) xlen
373	xlen -= size
374	if (h:flg .and. 2^3)<>0 # FNAME
375	while { src raw_read addressof:(var uInt8 ch) 1 ; ch<>0 and not src:atend }
376	void
377	if (h:flg .and. 2^4)<>0 # COMMENT
378	while { src raw_read addressof:(var uInt8 ch) 1 ; ch<>0 and not src:atend }
379	void
380	if (h:flg .and. 2^1)<>0 # FHCRC
381	src raw_read addressof:(var uInt16 crc16) 2
382	(var DateTime dt) seconds := (datetime 1970 1 1 0 0 0 0):seconds+h:mtime
383	if (deflate_uncompress src dest 0 (var Intn bytes_count) (var uInt32 crc))=failure
384	return failure
385	src raw_read addressof:(var uInt32 crc32) uInt32:size
386	src raw_read addressof:(var uInt32 isize) uInt32:size
387	status := shunt isize=bytes_count%2n^32 success failure
388
389
390	export zlib_uncompress gzip_uncompress