/pliant/language/stream/zlib.pli
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	#
3	# This program is free software; you can redistribute it and/or
4	# modify it under the terms of the GNU General Public License version 2
5	# as published by the Free Software Foundation.
6	#
7	# This program is distributed in the hope that it will be useful,
8	# but WITHOUT ANY WARRANTY; without even the implied warranty of
9	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10	# GNU General Public License for more details.
11	#
12	# You should have received a copy of the GNU General Public License
13	# version 2 along with this program; if not, write to the Free Software
14	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
15
16	scope "/pliant/language/stream/"
17	module "ring.pli"
18
19	# win32 DLL provided in Win32 Pliant tarball
20	# was picked in zlib114dll.zip on http://www.winimage.com/zLibDll/
21
22	constant zlib os_zlib_filename
23	constant version "1.1.3"
24	constant undocumented true
25
26	constant pliant_alloc os_api<>"win32"
27	constant buggy true
28
29
30	type z_stream_s
31	packed
32
33	field Address next_in
34	field Int avail_in
35	field Int total_in
36
37	field Address next_out
38	field Int avail_out
39	field Int total_out
40
41	field Address msg internal_state
42
43	field Address zalloc zfree opaque
44
45	field Int data_type
46	field Int adler
47	field Int reserved
48
49
50	if undocumented
51	constant Z_DEFLATED 8
52	constant Z_DEFAULT_STRATEGY 0
53
54
55	if undocumented
56	function deflateInit2_ stream level method window mem strategy version len -> err
57	arg_rw z_stream_s stream ; arg Int level method window mem strategy ; arg CStr version ; arg Int len err
58	external zlib "deflateInit2_"
59	else
60	function deflateInit_ stream level version len -> err
61	arg_rw z_stream_s stream ; arg Int level ; arg CStr version ; arg Int len err
62	external zlib "deflateInit_"
63
64	if undocumented
65	function deflateInit2 stream level method window mem strategy -> err
66	arg_rw z_stream_s stream ; arg Int level method window mem strategy ; arg Int err
67	err := deflateInit2_ stream level method window mem strategy version z_stream_s:size
68	else
69	function deflateInit stream level -> err
70	arg_rw z_stream_s stream ; arg Int level ; arg Int err
71	err := deflateInit_ stream level version z_stream_s:size
72
73	function deflate stream flush -> ret
74	arg_rw z_stream_s stream ; arg Int flush ; arg Int ret
75	external zlib "deflate"
76
77	function deflateEnd stream -> err
78	arg_rw z_stream_s stream ; arg Int err
79	external zlib "deflateEnd"
80
81
82	if undocumented
83	function inflateInit2_ stream window version len -> err
84	arg_rw z_stream_s stream ; arg Int window ; arg CStr version ; arg Int len err
85	external zlib "inflateInit2_"
86	else
87	function inflateInit_ stream version len -> err
88	arg_rw z_stream_s stream ; arg CStr version ; arg Int len err
89	external zlib "inflateInit_"
90
91	if undocumented
92	function inflateInit2 stream window -> err
93	arg_rw z_stream_s stream ; arg Int window ; arg Int err
94	err := inflateInit2_ stream window version z_stream_s:size
95	else
96	function inflateInit stream -> err
97	arg_rw z_stream_s stream ; arg Int err
98	err := inflateInit_ stream version z_stream_s:size
99
100	function inflate stream flush
101	arg_rw z_stream_s stream ; arg Int flush
102	external zlib "inflate"
103
104	function inflateReset stream
105	arg_rw z_stream_s stream
106	external zlib "inflateReset"
107
108	function inflateEnd stream -> err
109	arg_rw z_stream_s stream ; arg Int err
110	external zlib "inflateEnd"
111
112
113	if undocumented
114
115	type GzipHeader
116	packed
117	field uInt8 id1 id2
118	field uInt8 cm flg
119	field uInt32_li mtime
120	field uInt8 xfl os
121
122	gvar (Array uInt 256) crc_table
123	function init_table
124	for (var Int n) 0 255
125	var uInt c := n
126	for (var Int k) 0 7
127	if (c .and. 1)<>0
128	c := 0EDB88320h .xor. (c\2)
129	else
130	c := c\2
131	crc_table n := c
132	init_table
133
134	function crc32_update old_crc adr size -> new_crc
135	arg uInt old_crc new_crc ; arg Address adr ; arg Int size
136	var uInt c := old_crc .xor. 0FFFFFFFFh
137	for (var Int n) 0 size-1
138	var uInt b := (adr translate Byte n) map uInt8
139	var Int u := (c .xor. b) .and. 0FFh
140	c := crc_table:u .xor. (c\2^8)
141	new_crc := c .xor. 0FFFFFFFFh
142
143
144	if undocumented
145
146	type ZipHeader
147	field uInt32_li signature # 0
148	field uInt16_li version # 4
149	field uInt16_li flags # 6
150	field uInt16_li compression # 8
151	field uInt16_li time # 10
152	field uInt16_li date # 12
153	field uInt32_li crc # 14
154	field uInt32_li compressed_size # 18
155	field uInt32_li clear_size # 22
156	field uInt16_li name_length # 26
157	field uInt16_li extra_length # 28
158
159	type ZipTail
160	field uInt32_li signature # 0
161	field uInt32_li crc # 4
162	field uInt32_li compressed_size # 8
163	field uInt32_li uncompressed_size # 12
164
165
166
167
168
169	type CompressZlibStreamDriver
170	field Link:Stream s
171	field z_stream_s w
172	field z_stream_s r
173	field Int flags
174	if undocumented
175	field CBool gzip
176	field CBool zip
177	field CBool deflate
178	field uInt w_crc w_size
179	field uInt r_crc r_size
180	field Int zip_flags <- 0
181	field Str name
182	field DateTime datetime
183	field Str comment
184	StreamDriver maybe CompressZlibStreamDriver
185
186
187	method drv read buf mini maxi -> red
188	oarg_rw CompressZlibStreamDriver drv ; arg Address buf ; arg Int mini maxi red
189	if undocumented and (drv:zip_flags .and. 2^16)<>0
190	return 0
191	drv:r next_out := buf
192	drv:r avail_out := maxi
193	part inflate
194	while maxi-drv:r:avail_out<mini
195	if drv:s:atend
196	drv:r next_in := null
197	drv:r avail_in := 0
198	var Int old_avail_out := drv:r:avail_out
199	inflate drv:r 4 # Z_FINISH
200	if drv:r:avail_out=old_avail_out
201	leave inflate
202	else
203	drv:r next_in := drv:s:stream_read_cur
204	drv:r avail_in := (cast drv:s:stream_read_stop Int)-(cast drv:s:stream_read_cur Int)
205	var Int old_avail_in := drv:r:avail_in ; var Int old_avail_out := drv:r:avail_out
206	inflate drv:r 0
207	drv:s stream_read_cur := drv:r:next_in
208	if drv:r:avail_in=old_avail_in and drv:r:avail_out=old_avail_out
209	leave inflate
210	red := maxi-drv:r:avail_out
211	if undocumented and drv:gzip
212	drv r_crc := crc32_update drv:r_crc buf red
213	drv r_size += red
214
215
216	method drv write buf mini maxi -> written
217	oarg_rw CompressZlibStreamDriver drv ; arg Address buf ; arg Int mini maxi written
218	drv:w next_in := buf
219	drv:w avail_in := maxi
220	part deflate
221	while maxi-drv:w:avail_in<mini
222	if drv:s:stream_write_cur=drv:s:stream_write_stop
223	drv:s flush anytime
224	if drv:s=failure
225	leave deflate
226	else
227	drv:w next_out := drv:s stream_write_cur
228	drv:w avail_out := (cast drv:s:stream_write_stop Int)-(cast drv:s:stream_write_cur Int)
229	var Int old_avail_in := drv:w:avail_in ; var Int old_avail_out := drv:w:avail_out
230	deflate drv:w 0 # Z_NO_FLUSH
231	drv:s stream_write_cur := drv:w next_out
232	if drv:w:avail_in=old_avail_in and drv:w:avail_out=old_avail_out
233	leave deflate
234	written := maxi-drv:w:avail_in
235	if undocumented and drv:gzip
236	drv w_crc := crc32_update drv:w_crc buf written
237	drv w_size += written
238
239
240	method drv flush level -> status
241	oarg_rw CompressZlibStreamDriver drv ; arg Int level ; arg Status status
242	if (drv:flags .and. out)=0
243	return success
244	drv:w next_in := null
245	drv:w avail_in := 0
246	part deflate
247	while true
248	if drv:s:stream_write_cur=drv:s:stream_write_stop
249	drv:s flush anytime
250	if drv:s=failure
251	leave deflate
252	else
253	drv:w next_out := drv:s:stream_write_cur
254	drv:w avail_out := (cast drv:s:stream_write_stop Int)-(cast drv:s:stream_write_cur Int)
255	var Int old_avail_out := drv:w:avail_out
256	deflate drv:w (shunt level=end 4 2) # Z_FINISH Z_SYNC_FLUSH
257	drv:s stream_write_cur := drv:w next_out
258	if drv:w:avail_out=old_avail_out
259	leave deflate
260	if level<>end
261	drv:s flush level
262	status := shunt drv:s=success success failure
263
264
265	method drv close -> status
266	oarg_rw CompressZlibStreamDriver drv ; arg ExtendedStatus status
267	status := success
268	if (drv:flags .and. in)<>0
269	if not undocumented or (drv:zip_flags .and. 2^16)=0
270	if (inflateEnd drv:r)<>0
271	status := failure
272	if undocumented and drv:gzip
273	drv:s raw_read addressof:(var uInt32 crc) uInt32:size
274	drv:s raw_read addressof:(var uInt32 isize) uInt32:size
275	if isize%2n^32<>drv:r_size%2n^32 or crc<>drv:r_crc
276	status := failure
277	if undocumented and drv:zip and (drv:zip_flags .and. 8)<>0
278	drv:s raw_read addressof:(var ZipTail tail) ZipTail:size
279	if (drv:flags .and. out)<>0
280	if (deflateEnd drv:w)<>0
281	status := failure
282	if undocumented and drv:gzip
283	var uInt32 crc := drv w_crc ; drv:s raw_write addressof:crc uInt32:size
284	var uInt32 isize := drv w_size; drv:s raw_write addressof:isize uInt32:size
285
286
287	method drv query command stream answer -> status
288	oarg_rw CompressZlibStreamDriver drv ; arg Str command ; arg_rw Stream stream ; arg_w Str answer ; arg ExtendedStatus status
289	if command="encoding"
290	if undocumented
291	answer := shunt drv:gzip "gzip" drv:zip "zip" drv:deflate "deflate" "zlib"
292	else
293	answer := "zlib"
294	status := success
295	eif undocumented and command="name"
296	answer := drv name
297	status := success
298	eif undocumented and command="datetime"
299	answer := string drv:datetime
300	status := success
301	eif undocumented and command="comment"
302	answer := drv comment
303	status := success
304	else
305	status := drv:s:stream_driver query command drv:s answer
306
307
308	method drv configure command stream -> status
309	oarg_rw CompressZlibStreamDriver drv ; arg Str command ; arg_rw Stream stream ; arg ExtendedStatus status
310	status := drv:s:stream_driver configure command drv:s
311
312
313
314
315
316	type CompressZlibFileSystem
317	void
318	FileSystem maybe CompressZlibFileSystem
319
320
321	if pliant_alloc
322
323	function pliant_zalloc opaque items size -> adr
324	arg Address opaque ; arg uInt items size ; arg Address adr
325	external_calling_convention
326	if buggy
327	var Address ptr := memory_allocate items*size+2*uInt:size null
328	ptr map uInt := 763F526Ch
329	ptr map uInt 1 := 946E0497h
330	adr := ptr translate uInt 2
331	else
332	adr := memory_allocate items*size null
333
334	function pliant_zfree opaque adr
335	arg Address opaque ; arg Address adr
336	external_calling_convention
337	if buggy
338	var Address ptr := adr translate uInt -2
339	if (ptr map uInt)=763F526Ch and (ptr map uInt 1)=946E0497h
340	ptr map uInt := AC76EF15h
341	ptr map uInt 1 := 037356C1h
342	memory_free ptr
343	else
344	(var Stream s) open "file:/tmp/zlib_bug.log" append+safe
345	s writeline string:datetime+(shunt (ptr map uInt)=AC76EF15h and (ptr map uInt 1)=037356C1h " twice" "wrong")
346	s close
347	else
348	memory_free adr
349
350
351	method fs open name options flags stream support -> status
352	oarg_rw CompressZlibFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
353	if undocumented
354	var CBool gzip := options option "gzip"
355	var CBool zip := options option "zip"
356	var CBool deflate := gzip or zip or (options option "deflate")
357	var Int level := options option "level" Int
358	var Link:Stream s
359	if exists:support
360	s :> support
361	else
362	var Link:Stream s :> new Stream
363	s open name options (flags .and. in+out+append+safe)
364	if s=failure
365	return failure
366	var Link:CompressZlibStreamDriver drv :> new CompressZlibStreamDriver
367	if (flags .and. out)<>0
368	if (options option "header" Str)<>""
369	s writeline (options option "header" Str)
370	s writeline ""
371	if undocumented and gzip
372	var Str comment := options option "comment" Str
373	var GzipHeader h
374	h id1 := 1Fh ; h id2 := 8Bh ; h cm := 8 ; h flg := shunt comment:len<>0 2^4 0 ; h xfl := 2 ; h os := 255
375	s raw_write addressof:h GzipHeader:size
376	if comment:len<>0
377	s writechars comment
378	s writechars character:0
379	drv w_crc := 0 ; drv w_size := 0
380	memory_clear (addressof drv:w) z_stream_s:size
381	drv:w data_type := 2
382	if pliant_alloc
383	drv:w zalloc := (the_function pliant_zalloc Address uInt uInt -> Address) executable
384	drv:w zfree := (the_function pliant_zfree Address Address) executable
385	if undocumented
386	if (deflateInit2 drv:w (shunt level=defined level -1) Z_DEFLATED (shunt deflate -15 15) 8 Z_DEFAULT_STRATEGY)<>0
387	return failure
388	else
389	if (deflateInit drv:w (shunt level=defined level -1))<>0
390	return failure
391	if (flags .and. in)<>0
392	if (options option "header")
393	while s:readline<>""
394	void
395	if undocumented and gzip
396	s raw_read addressof:(var GzipHeader h) GzipHeader:size
397	if h:id1<>1Fh or h:id2<>8Bh
398	return failure:"not a gzip stream"
399	if h:cm<>8
400	return failure:"no at gzip stream"
401	if (h:flg .and. 2^2)<>0 # FEXTRA
402	s raw_read addressof:(var uInt16_li xlen) 2
403	while xlen>=0 and not s:atend
404	s read_available (var Address adr) (var Int size) xlen
405	xlen -= size
406	if (h:flg .and. 2^3)<>0 # FNAME
407	while { s raw_read addressof:(var uInt8 ch) 1 ; ch<>0 and not s:atend }
408	void
409	if (h:flg .and. 2^4)<>0 # COMMENT
410	while { s raw_read addressof:(var uInt8 ch) 1 ; ch<>0 and not s:atend }
411	drv comment += character ch
412	if (h:flg .and. 2^1)<>0 # FHCRC
413	s raw_read addressof:(var uInt16 crc16) 2
414	drv r_crc := 0 ; drv r_size := 0
415	if undocumented and zip
416	s raw_read addressof:(var ZipHeader zh) ZipHeader:size
417	if zh:signature<>04034B50h
418	return failure:"not a zip stream"
419	drv zip_flags := zh flags
420	if zh:compressed_size=0 and zh:clear_size=0 and (zh:flags .and. 8)=0
421	drv zip_flags += 2^16
422	drv:name resize zh:name_length
423	drv datetime := datetime 1980+zh:date\2^9 zh:date\2^5%2^4 zh:date%2^5 zh:time\2^11 zh:time\2^5%2^6 zh:time%2^5*2 0
424	s raw_read drv:name:characters zh:name_length
425	for (var Int i) 1 zh:extra_length
426	s raw_read addressof:(var Byte drop) 1
427	memory_clear (addressof drv:r) z_stream_s:size
428	drv:r data_type := 2
429	if pliant_alloc
430	drv:r zalloc := (the_function pliant_zalloc Address uInt uInt -> Address) executable
431	drv:r zfree := (the_function pliant_zfree Address Address) executable
432	if undocumented
433	if (drv:zip_flags .and. 2^16)=0
434	if (inflateInit2 drv:r (shunt deflate -15 15))<>0
435	return failure
436	else
437	if (inflateInit drv:r)<>0
438	return failure
439	drv s :> s
440	drv flags := flags
441	if undocumented
442	drv gzip := gzip
443	drv zip := zip
444	drv deflate := deflate
445	stream stream_driver :> drv
446	status := success
447
448
449	gvar CompressZlibFileSystem compress_zlib_file_system
450	pliant_multi_file_system mount "zlib:" "" compress_zlib_file_system
451	if undocumented
452	pliant_multi_file_system mount "deflate:" "" "deflate" compress_zlib_file_system
453	pliant_multi_file_system mount "gzip:" "" "gzip" compress_zlib_file_system
454	pliant_multi_file_system mount "zip:" "" "zip" compress_zlib_file_system