summaryrefslogtreecommitdiff
path: root/contrib/ada
diff options
context:
space:
mode:
authorMark Adler <madler@alumni.caltech.edu>2011-09-09 23:22:37 -0700
committerMark Adler <madler@alumni.caltech.edu>2011-09-09 23:22:37 -0700
commit4b5a43a219d51066c01ff2ab86af18b967f2d0dd (patch)
tree4dcaf0cd18751d04cf638a9a6ec521990d4f2e90 /contrib/ada
parent086e982175da84b3db958191031380794315f95f (diff)
downloadzlib-1.2.0.5.tar.gz
zlib-1.2.0.5.tar.bz2
zlib-1.2.0.5.zip
zlib 1.2.0.5v1.2.0.5
Diffstat (limited to 'contrib/ada')
-rw-r--r--contrib/ada/mtest.adb153
-rw-r--r--contrib/ada/read.adb151
-rw-r--r--contrib/ada/readme.txt52
-rw-r--r--contrib/ada/test.adb463
-rw-r--r--contrib/ada/zlib-streams.adb215
-rw-r--r--contrib/ada/zlib-streams.ads112
-rw-r--r--contrib/ada/zlib-thin.adb185
-rw-r--r--contrib/ada/zlib-thin.ads478
-rw-r--r--contrib/ada/zlib.adb674
-rw-r--r--contrib/ada/zlib.ads311
-rw-r--r--contrib/ada/zlib.gpr21
11 files changed, 2815 insertions, 0 deletions
diff --git a/contrib/ada/mtest.adb b/contrib/ada/mtest.adb
new file mode 100644
index 0000000..91a96cd
--- /dev/null
+++ b/contrib/ada/mtest.adb
@@ -0,0 +1,153 @@
1----------------------------------------------------------------
2-- ZLib for Ada thick binding. --
3-- --
4-- Copyright (C) 2002-2003 Dmitriy Anisimkov --
5-- --
6-- Open source license information is in the zlib.ads file. --
7----------------------------------------------------------------
8-- Continuous test for ZLib multithreading. If the test is fail
9-- Wou should provide thread safe allocation routines for the Z_Stream.
10--
11-- $Id: mtest.adb,v 1.2 2003/08/12 12:11:05 vagul Exp $
12
13with ZLib;
14with Ada.Streams;
15with Ada.Numerics.Discrete_Random;
16with Ada.Text_IO;
17with Ada.Exceptions;
18with Ada.Task_Identification;
19
20procedure MTest is
21 use Ada.Streams;
22 use ZLib;
23
24 Stop : Boolean := False;
25
26 pragma Atomic (Stop);
27
28 subtype Visible_Symbols is Stream_Element range 16#20# .. 16#7E#;
29
30 package Random_Elements is
31 new Ada.Numerics.Discrete_Random (Visible_Symbols);
32
33 task type Test_Task;
34
35 task body Test_Task is
36 Buffer : Stream_Element_Array (1 .. 100_000);
37 Gen : Random_Elements.Generator;
38
39 Buffer_First : Stream_Element_Offset;
40 Compare_First : Stream_Element_Offset;
41
42 Deflate : Filter_Type;
43 Inflate : Filter_Type;
44
45 procedure Further (Item : in Stream_Element_Array);
46
47 procedure Read_Buffer
48 (Item : out Ada.Streams.Stream_Element_Array;
49 Last : out Ada.Streams.Stream_Element_Offset);
50
51 -------------
52 -- Further --
53 -------------
54
55 procedure Further (Item : in Stream_Element_Array) is
56
57 procedure Compare (Item : in Stream_Element_Array);
58
59 -------------
60 -- Compare --
61 -------------
62
63 procedure Compare (Item : in Stream_Element_Array) is
64 Next_First : Stream_Element_Offset := Compare_First + Item'Length;
65 begin
66 if Buffer (Compare_First .. Next_First - 1) /= Item then
67 raise Program_Error;
68 end if;
69
70 Compare_First := Next_First;
71 end Compare;
72
73 procedure Compare_Write is new ZLib.Write (Write => Compare);
74 begin
75 Compare_Write (Inflate, Item, No_Flush);
76 end Further;
77
78 -----------------
79 -- Read_Buffer --
80 -----------------
81
82 procedure Read_Buffer
83 (Item : out Ada.Streams.Stream_Element_Array;
84 Last : out Ada.Streams.Stream_Element_Offset)
85 is
86 Buff_Diff : Stream_Element_Offset := Buffer'Last - Buffer_First;
87 Next_First : Stream_Element_Offset;
88 begin
89 if Item'Length <= Buff_Diff then
90 Last := Item'Last;
91
92 Next_First := Buffer_First + Item'Length;
93
94 Item := Buffer (Buffer_First .. Next_First - 1);
95
96 Buffer_First := Next_First;
97 else
98 Last := Item'First + Buff_Diff;
99 Item (Item'First .. Last) := Buffer (Buffer_First .. Buffer'Last);
100 Buffer_First := Buffer'Last + 1;
101 end if;
102 end Read_Buffer;
103
104 procedure Translate is new Generic_Translate
105 (Data_In => Read_Buffer,
106 Data_Out => Further);
107
108 begin
109 Random_Elements.Reset (Gen);
110
111 Buffer := (others => 20);
112
113 Main : loop
114 for J in Buffer'Range loop
115 Buffer (J) := Random_Elements.Random (Gen);
116
117 Deflate_Init (Deflate);
118 Inflate_Init (Inflate);
119
120 Buffer_First := Buffer'First;
121 Compare_First := Buffer'First;
122
123 Translate (Deflate);
124
125 if Compare_First /= Buffer'Last + 1 then
126 raise Program_Error;
127 end if;
128
129 Ada.Text_IO.Put_Line
130 (Ada.Task_Identification.Image
131 (Ada.Task_Identification.Current_Task)
132 & Stream_Element_Offset'Image (J)
133 & ZLib.Count'Image (Total_Out (Deflate)));
134
135 Close (Deflate);
136 Close (Inflate);
137
138 exit Main when Stop;
139 end loop;
140 end loop Main;
141 exception
142 when E : others =>
143 Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
144 Stop := True;
145 end Test_Task;
146
147 Test : array (1 .. 4) of Test_Task;
148
149 pragma Unreferenced (Test);
150
151begin
152 null;
153end MTest;
diff --git a/contrib/ada/read.adb b/contrib/ada/read.adb
new file mode 100644
index 0000000..184ea00
--- /dev/null
+++ b/contrib/ada/read.adb
@@ -0,0 +1,151 @@
1----------------------------------------------------------------
2-- ZLib for Ada thick binding. --
3-- --
4-- Copyright (C) 2002-2003 Dmitriy Anisimkov --
5-- --
6-- Open source license information is in the zlib.ads file. --
7----------------------------------------------------------------
8
9-- $Id: read.adb,v 1.7 2003/08/12 12:12:35 vagul Exp $
10
11-- Test/demo program for the generic read interface.
12
13with Ada.Numerics.Discrete_Random;
14with Ada.Streams;
15with Ada.Text_IO;
16
17with ZLib;
18
19procedure Read is
20
21 use Ada.Streams;
22
23 ------------------------------------
24 -- Test configuration parameters --
25 ------------------------------------
26
27 File_Size : Stream_Element_Offset := 100_000;
28
29 Continuous : constant Boolean := False;
30 -- If this constant is True, the test would be repeated again and again,
31 -- with increment File_Size for every iteration.
32
33 Header : constant ZLib.Header_Type := ZLib.Default;
34 -- Do not use Header other than Default in ZLib versions 1.1.4 and older.
35
36 Init_Random : constant := 8;
37 -- We are using the same random sequence, in case of we catch bug,
38 -- so we would be able to reproduce it.
39
40 -- End --
41
42 Pack_Size : Stream_Element_Offset;
43 Offset : Stream_Element_Offset;
44
45 Filter : ZLib.Filter_Type;
46
47 subtype Visible_Symbols
48 is Stream_Element range 16#20# .. 16#7E#;
49
50 package Random_Elements is new
51 Ada.Numerics.Discrete_Random (Visible_Symbols);
52
53 Gen : Random_Elements.Generator;
54 Period : constant Stream_Element_Offset := 200;
55 -- Period constant variable for random generator not to be very random.
56 -- Bigger period, harder random.
57
58 Read_Buffer : Stream_Element_Array (1 .. 2048);
59 Read_First : Stream_Element_Offset;
60 Read_Last : Stream_Element_Offset;
61
62 procedure Reset;
63
64 procedure Read
65 (Item : out Stream_Element_Array;
66 Last : out Stream_Element_Offset);
67 -- this procedure is for generic instantiation of
68 -- ZLib.Read
69 -- reading data from the File_In.
70
71 procedure Read is new ZLib.Read (Read, Read_Buffer, Read_First, Read_Last);
72
73 ----------
74 -- Read --
75 ----------
76
77 procedure Read
78 (Item : out Stream_Element_Array;
79 Last : out Stream_Element_Offset) is
80 begin
81 Last := Stream_Element_Offset'Min
82 (Item'Last,
83 Item'First + File_Size - Offset);
84
85 for J in Item'First .. Last loop
86 if J < Item'First + Period then
87 Item (J) := Random_Elements.Random (Gen);
88 else
89 Item (J) := Item (J - Period);
90 end if;
91
92 Offset := Offset + 1;
93 end loop;
94 end Read;
95
96 -----------
97 -- Reset --
98 -----------
99
100 procedure Reset is
101 begin
102 Random_Elements.Reset (Gen, Init_Random);
103 Pack_Size := 0;
104 Offset := 1;
105 Read_First := Read_Buffer'Last + 1;
106 end Reset;
107
108begin
109 Ada.Text_IO.Put_Line ("ZLib " & ZLib.Version);
110
111 loop
112 for Level in ZLib.Compression_Level'Range loop
113
114 Ada.Text_IO.Put ("Level ="
115 & ZLib.Compression_Level'Image (Level));
116
117 -- Deflate using generic instantiation.
118
119 ZLib.Deflate_Init
120 (Filter,
121 Level,
122 Header => Header);
123
124 Reset;
125
126 Ada.Text_IO.Put
127 (Stream_Element_Offset'Image (File_Size) & " ->");
128
129 loop
130 declare
131 Buffer : Stream_Element_Array (1 .. 1024);
132 Last : Stream_Element_Offset;
133 begin
134 Read (Filter, Buffer, Last);
135
136 Pack_Size := Pack_Size + Last - Buffer'First + 1;
137
138 exit when Last < Buffer'Last;
139 end;
140 end loop;
141
142 Ada.Text_IO.Put_Line (Stream_Element_Offset'Image (Pack_Size));
143
144 ZLib.Close (Filter);
145 end loop;
146
147 exit when not Continuous;
148
149 File_Size := File_Size + 1;
150 end loop;
151end Read;
diff --git a/contrib/ada/readme.txt b/contrib/ada/readme.txt
new file mode 100644
index 0000000..ad02c22
--- /dev/null
+++ b/contrib/ada/readme.txt
@@ -0,0 +1,52 @@
1
2 ZLib for Ada thick binding (ZLib.Ada)
3 Release 1.2
4
5ZLib.Ada is a thick binding interface to the popular ZLib data
6compression library, available at http://www.gzip.org/zlib/.
7It provides Ada-style access to the ZLib C library.
8
9
10 Here are the main changes since ZLib.Ada 1.1:
11
12- The default header type has a name "Default" now. Auto is used only for
13 automatic GZip/ZLib header detection.
14
15- Added test for multitasking mtest.adb.
16
17- Added GNAT project file zlib.gpr.
18
19
20 How to build ZLib.Ada under GNAT
21
22You should have the ZLib library already build on your computer, before
23building ZLib.Ada. Make the directory of ZLib.Ada sources current and
24issue the command:
25
26 gnatmake test -largs -L<directory where libz.a is> -lz
27
28Or use the GNAT project file build for GNAT 3.15 or later:
29
30 gnatmake -Pzlib.gpr -L<directory where libz.a is>
31
32
33 How to build ZLib.Ada under Aonix ObjectAda for Win32 7.2.2
34
351. Make a project with all *.ads and *.adb files from the distribution.
362. Build the libz.a library from the ZLib C sources.
373. Rename libz.a to z.lib.
384. Add the library z.lib to the project.
395. Add the libc.lib library from the ObjectAda distribution to the project.
406. Build the executable using test.adb as a main procedure.
41
42
43 How to use ZLib.Ada
44
45The source files test.adb and read.adb are small demo programs that show
46the main functionality of ZLib.Ada.
47
48The routines from the package specifications are commented.
49
50
51Homepage: http://zlib-ada.sourceforge.net/
52Author: Dmitriy Anisimkov <anisimkov@yahoo.com>
diff --git a/contrib/ada/test.adb b/contrib/ada/test.adb
new file mode 100644
index 0000000..90773ac
--- /dev/null
+++ b/contrib/ada/test.adb
@@ -0,0 +1,463 @@
1----------------------------------------------------------------
2-- ZLib for Ada thick binding. --
3-- --
4-- Copyright (C) 2002-2003 Dmitriy Anisimkov --
5-- --
6-- Open source license information is in the zlib.ads file. --
7----------------------------------------------------------------
8
9-- $Id: test.adb,v 1.17 2003/08/12 12:13:30 vagul Exp $
10
11-- The program has a few aims.
12-- 1. Test ZLib.Ada95 thick binding functionality.
13-- 2. Show the example of use main functionality of the ZLib.Ada95 binding.
14-- 3. Build this program automatically compile all ZLib.Ada95 packages under
15-- GNAT Ada95 compiler.
16
17with ZLib.Streams;
18with Ada.Streams.Stream_IO;
19with Ada.Numerics.Discrete_Random;
20
21with Ada.Text_IO;
22
23with Ada.Calendar;
24
25procedure Test is
26
27 use Ada.Streams;
28 use Stream_IO;
29
30 ------------------------------------
31 -- Test configuration parameters --
32 ------------------------------------
33
34 File_Size : Count := 100_000;
35 Continuous : constant Boolean := False;
36
37 Header : constant ZLib.Header_Type := ZLib.Default;
38 -- ZLib.None;
39 -- ZLib.Auto;
40 -- ZLib.GZip;
41 -- Do not use Header other then Default in ZLib versions 1.1.4
42 -- and older.
43
44 Strategy : constant ZLib.Strategy_Type := ZLib.Default_Strategy;
45 Init_Random : constant := 10;
46
47 -- End --
48
49 In_File_Name : constant String := "testzlib.in";
50 -- Name of the input file
51
52 Z_File_Name : constant String := "testzlib.zlb";
53 -- Name of the compressed file.
54
55 Out_File_Name : constant String := "testzlib.out";
56 -- Name of the decompressed file.
57
58 File_In : File_Type;
59 File_Out : File_Type;
60 File_Back : File_Type;
61 File_Z : ZLib.Streams.Stream_Type;
62
63 Filter : ZLib.Filter_Type;
64
65 Time_Stamp : Ada.Calendar.Time;
66
67 procedure Generate_File;
68 -- Generate file of spetsified size with some random data.
69 -- The random data is repeatable, for the good compression.
70
71 procedure Compare_Streams
72 (Left, Right : in out Root_Stream_Type'Class);
73 -- The procedure compearing data in 2 streams.
74 -- It is for compare data before and after compression/decompression.
75
76 procedure Compare_Files (Left, Right : String);
77 -- Compare files. Based on the Compare_Streams.
78
79 procedure Copy_Streams
80 (Source, Target : in out Root_Stream_Type'Class;
81 Buffer_Size : in Stream_Element_Offset := 1024);
82 -- Copying data from one stream to another. It is for test stream
83 -- interface of the library.
84
85 procedure Data_In
86 (Item : out Stream_Element_Array;
87 Last : out Stream_Element_Offset);
88 -- this procedure is for generic instantiation of
89 -- ZLib.Generic_Translate.
90 -- reading data from the File_In.
91
92 procedure Data_Out (Item : in Stream_Element_Array);
93 -- this procedure is for generic instantiation of
94 -- ZLib.Generic_Translate.
95 -- writing data to the File_Out.
96
97 procedure Stamp;
98 -- Store the timestamp to the local variable.
99
100 procedure Print_Statistic (Msg : String; Data_Size : ZLib.Count);
101 -- Print the time statistic with the message.
102
103 procedure Translate is new ZLib.Generic_Translate
104 (Data_In => Data_In,
105 Data_Out => Data_Out);
106 -- This procedure is moving data from File_In to File_Out
107 -- with compression or decompression, depend on initialization of
108 -- Filter parameter.
109
110 -------------------
111 -- Compare_Files --
112 -------------------
113
114 procedure Compare_Files (Left, Right : String) is
115 Left_File, Right_File : File_Type;
116 begin
117 Open (Left_File, In_File, Left);
118 Open (Right_File, In_File, Right);
119 Compare_Streams (Stream (Left_File).all, Stream (Right_File).all);
120 Close (Left_File);
121 Close (Right_File);
122 end Compare_Files;
123
124 ---------------------
125 -- Compare_Streams --
126 ---------------------
127
128 procedure Compare_Streams
129 (Left, Right : in out Ada.Streams.Root_Stream_Type'Class)
130 is
131 Left_Buffer, Right_Buffer : Stream_Element_Array (0 .. 16#FFF#);
132 Left_Last, Right_Last : Stream_Element_Offset;
133 begin
134 loop
135 Read (Left, Left_Buffer, Left_Last);
136 Read (Right, Right_Buffer, Right_Last);
137
138 if Left_Last /= Right_Last then
139 Ada.Text_IO.Put_Line ("Compare error :"
140 & Stream_Element_Offset'Image (Left_Last)
141 & " /= "
142 & Stream_Element_Offset'Image (Right_Last));
143
144 raise Constraint_Error;
145
146 elsif Left_Buffer (0 .. Left_Last)
147 /= Right_Buffer (0 .. Right_Last)
148 then
149 Ada.Text_IO.Put_Line ("ERROR: IN and OUT files is not equal.");
150 raise Constraint_Error;
151
152 end if;
153
154 exit when Left_Last < Left_Buffer'Last;
155 end loop;
156 end Compare_Streams;
157
158 ------------------
159 -- Copy_Streams --
160 ------------------
161
162 procedure Copy_Streams
163 (Source, Target : in out Ada.Streams.Root_Stream_Type'Class;
164 Buffer_Size : in Stream_Element_Offset := 1024)
165 is
166 Buffer : Stream_Element_Array (1 .. Buffer_Size);
167 Last : Stream_Element_Offset;
168 begin
169 loop
170 Read (Source, Buffer, Last);
171 Write (Target, Buffer (1 .. Last));
172
173 exit when Last < Buffer'Last;
174 end loop;
175 end Copy_Streams;
176
177 -------------
178 -- Data_In --
179 -------------
180
181 procedure Data_In
182 (Item : out Stream_Element_Array;
183 Last : out Stream_Element_Offset) is
184 begin
185 Read (File_In, Item, Last);
186 end Data_In;
187
188 --------------
189 -- Data_Out --
190 --------------
191
192 procedure Data_Out (Item : in Stream_Element_Array) is
193 begin
194 Write (File_Out, Item);
195 end Data_Out;
196
197 -------------------
198 -- Generate_File --
199 -------------------
200
201 procedure Generate_File is
202 subtype Visible_Symbols is Stream_Element range 16#20# .. 16#7E#;
203
204 package Random_Elements is
205 new Ada.Numerics.Discrete_Random (Visible_Symbols);
206
207 Gen : Random_Elements.Generator;
208 Buffer : Stream_Element_Array := (1 .. 77 => 16#20#) & 10;
209
210 Buffer_Count : constant Count := File_Size / Buffer'Length;
211 -- Number of same buffers in the packet.
212
213 Density : constant Count := 30; -- from 0 to Buffer'Length - 2;
214
215 procedure Fill_Buffer (J, D : in Count);
216 -- Change the part of the buffer.
217
218 -----------------
219 -- Fill_Buffer --
220 -----------------
221
222 procedure Fill_Buffer (J, D : in Count) is
223 begin
224 for K in 0 .. D loop
225 Buffer
226 (Stream_Element_Offset ((J + K) mod (Buffer'Length - 1) + 1))
227 := Random_Elements.Random (Gen);
228
229 end loop;
230 end Fill_Buffer;
231
232 begin
233 Random_Elements.Reset (Gen, Init_Random);
234
235 Create (File_In, Out_File, In_File_Name);
236
237 Fill_Buffer (1, Buffer'Length - 2);
238
239 for J in 1 .. Buffer_Count loop
240 Write (File_In, Buffer);
241
242 Fill_Buffer (J, Density);
243 end loop;
244
245 -- fill remain size.
246
247 Write
248 (File_In,
249 Buffer
250 (1 .. Stream_Element_Offset
251 (File_Size - Buffer'Length * Buffer_Count)));
252
253 Flush (File_In);
254 Close (File_In);
255 end Generate_File;
256
257 ---------------------
258 -- Print_Statistic --
259 ---------------------
260
261 procedure Print_Statistic (Msg : String; Data_Size : ZLib.Count) is
262 use Ada.Calendar;
263 use Ada.Text_IO;
264
265 package Count_IO is new Integer_IO (ZLib.Count);
266
267 Curr_Dur : Duration := Clock - Time_Stamp;
268 begin
269 Put (Msg);
270
271 Set_Col (20);
272 Ada.Text_IO.Put ("size =");
273
274 Count_IO.Put
275 (Data_Size,
276 Width => Stream_IO.Count'Image (File_Size)'Length);
277
278 Put_Line (" duration =" & Duration'Image (Curr_Dur));
279 end Print_Statistic;
280
281 -----------
282 -- Stamp --
283 -----------
284
285 procedure Stamp is
286 begin
287 Time_Stamp := Ada.Calendar.Clock;
288 end Stamp;
289
290begin
291 Ada.Text_IO.Put_Line ("ZLib " & ZLib.Version);
292
293 loop
294 Generate_File;
295
296 for Level in ZLib.Compression_Level'Range loop
297
298 Ada.Text_IO.Put_Line ("Level ="
299 & ZLib.Compression_Level'Image (Level));
300
301 -- Test generic interface.
302 Open (File_In, In_File, In_File_Name);
303 Create (File_Out, Out_File, Z_File_Name);
304
305 Stamp;
306
307 -- Deflate using generic instantiation.
308
309 ZLib.Deflate_Init
310 (Filter => Filter,
311 Level => Level,
312 Strategy => Strategy,
313 Header => Header);
314
315 Translate (Filter);
316 Print_Statistic ("Generic compress", ZLib.Total_Out (Filter));
317 ZLib.Close (Filter);
318
319 Close (File_In);
320 Close (File_Out);
321
322 Open (File_In, In_File, Z_File_Name);
323 Create (File_Out, Out_File, Out_File_Name);
324
325 Stamp;
326
327 -- Inflate using generic instantiation.
328
329 ZLib.Inflate_Init (Filter, Header => Header);
330
331 Translate (Filter);
332 Print_Statistic ("Generic decompress", ZLib.Total_Out (Filter));
333
334 ZLib.Close (Filter);
335
336 Close (File_In);
337 Close (File_Out);
338
339 Compare_Files (In_File_Name, Out_File_Name);
340
341 -- Test stream interface.
342
343 -- Compress to the back stream.
344
345 Open (File_In, In_File, In_File_Name);
346 Create (File_Back, Out_File, Z_File_Name);
347
348 Stamp;
349
350 ZLib.Streams.Create
351 (Stream => File_Z,
352 Mode => ZLib.Streams.Out_Stream,
353 Back => ZLib.Streams.Stream_Access
354 (Stream (File_Back)),
355 Back_Compressed => True,
356 Level => Level,
357 Strategy => Strategy,
358 Header => Header);
359
360 Copy_Streams
361 (Source => Stream (File_In).all,
362 Target => File_Z);
363
364 -- Flushing internal buffers to the back stream.
365
366 ZLib.Streams.Flush (File_Z, ZLib.Finish);
367
368 Print_Statistic ("Write compress",
369 ZLib.Streams.Write_Total_Out (File_Z));
370
371 ZLib.Streams.Close (File_Z);
372
373 Close (File_In);
374 Close (File_Back);
375
376 -- Compare reading from original file and from
377 -- decompression stream.
378
379 Open (File_In, In_File, In_File_Name);
380 Open (File_Back, In_File, Z_File_Name);
381
382 ZLib.Streams.Create
383 (Stream => File_Z,
384 Mode => ZLib.Streams.In_Stream,
385 Back => ZLib.Streams.Stream_Access
386 (Stream (File_Back)),
387 Back_Compressed => True,
388 Header => Header);
389
390 Stamp;
391 Compare_Streams (Stream (File_In).all, File_Z);
392
393 Print_Statistic ("Read decompress",
394 ZLib.Streams.Read_Total_Out (File_Z));
395
396 ZLib.Streams.Close (File_Z);
397 Close (File_In);
398 Close (File_Back);
399
400 -- Compress by reading from compression stream.
401
402 Open (File_Back, In_File, In_File_Name);
403 Create (File_Out, Out_File, Z_File_Name);
404
405 ZLib.Streams.Create
406 (Stream => File_Z,
407 Mode => ZLib.Streams.In_Stream,
408 Back => ZLib.Streams.Stream_Access
409 (Stream (File_Back)),
410 Back_Compressed => False,
411 Level => Level,
412 Strategy => Strategy,
413 Header => Header);
414
415 Stamp;
416 Copy_Streams
417 (Source => File_Z,
418 Target => Stream (File_Out).all);
419
420 Print_Statistic ("Read compress",
421 ZLib.Streams.Read_Total_Out (File_Z));
422
423 ZLib.Streams.Close (File_Z);
424
425 Close (File_Out);
426 Close (File_Back);
427
428 -- Decompress to decompression stream.
429
430 Open (File_In, In_File, Z_File_Name);
431 Create (File_Back, Out_File, Out_File_Name);
432
433 ZLib.Streams.Create
434 (Stream => File_Z,
435 Mode => ZLib.Streams.Out_Stream,
436 Back => ZLib.Streams.Stream_Access
437 (Stream (File_Back)),
438 Back_Compressed => False,
439 Header => Header);
440
441 Stamp;
442
443 Copy_Streams
444 (Source => Stream (File_In).all,
445 Target => File_Z);
446
447 Print_Statistic ("Write decompress",
448 ZLib.Streams.Write_Total_Out (File_Z));
449
450 ZLib.Streams.Close (File_Z);
451 Close (File_In);
452 Close (File_Back);
453
454 Compare_Files (In_File_Name, Out_File_Name);
455 end loop;
456
457 Ada.Text_IO.Put_Line (Count'Image (File_Size) & " Ok.");
458
459 exit when not Continuous;
460
461 File_Size := File_Size + 1;
462 end loop;
463end Test;
diff --git a/contrib/ada/zlib-streams.adb b/contrib/ada/zlib-streams.adb
new file mode 100644
index 0000000..d213b5c
--- /dev/null
+++ b/contrib/ada/zlib-streams.adb
@@ -0,0 +1,215 @@
1----------------------------------------------------------------
2-- ZLib for Ada thick binding. --
3-- --
4-- Copyright (C) 2002-2003 Dmitriy Anisimkov --
5-- --
6-- Open source license information is in the zlib.ads file. --
7----------------------------------------------------------------
8
9-- $Id: zlib-streams.adb,v 1.9 2003/08/12 13:15:31 vagul Exp $
10
11with Ada.Unchecked_Deallocation;
12
13package body ZLib.Streams is
14
15 -----------
16 -- Close --
17 -----------
18
19 procedure Close (Stream : in out Stream_Type) is
20 procedure Free is new Ada.Unchecked_Deallocation
21 (Stream_Element_Array, Buffer_Access);
22 begin
23 if Stream.Mode = Out_Stream or Stream.Mode = Duplex then
24 -- We should flush the data written by the writer.
25
26 Flush (Stream, Finish);
27
28 Close (Stream.Writer);
29 end if;
30
31 if Stream.Mode = In_Stream or Stream.Mode = Duplex then
32 Close (Stream.Reader);
33 Free (Stream.Buffer);
34 end if;
35 end Close;
36
37 ------------
38 -- Create --
39 ------------
40
41 procedure Create
42 (Stream : out Stream_Type;
43 Mode : in Stream_Mode;
44 Back : in Stream_Access;
45 Back_Compressed : in Boolean;
46 Level : in Compression_Level := Default_Compression;
47 Strategy : in Strategy_Type := Default_Strategy;
48 Header : in Header_Type := Default;
49 Read_Buffer_Size : in Ada.Streams.Stream_Element_Offset
50 := Default_Buffer_Size;
51 Write_Buffer_Size : in Ada.Streams.Stream_Element_Offset
52 := Default_Buffer_Size)
53 is
54
55 subtype Buffer_Subtype is Stream_Element_Array (1 .. Read_Buffer_Size);
56
57 procedure Init_Filter
58 (Filter : in out Filter_Type;
59 Compress : in Boolean);
60
61 -----------------
62 -- Init_Filter --
63 -----------------
64
65 procedure Init_Filter
66 (Filter : in out Filter_Type;
67 Compress : in Boolean) is
68 begin
69 if Compress then
70 Deflate_Init
71 (Filter, Level, Strategy, Header => Header);
72 else
73 Inflate_Init (Filter, Header => Header);
74 end if;
75 end Init_Filter;
76
77 begin
78 Stream.Back := Back;
79 Stream.Mode := Mode;
80
81 if Mode = Out_Stream or Mode = Duplex then
82 Init_Filter (Stream.Writer, Back_Compressed);
83 Stream.Buffer_Size := Write_Buffer_Size;
84 else
85 Stream.Buffer_Size := 0;
86 end if;
87
88 if Mode = In_Stream or Mode = Duplex then
89 Init_Filter (Stream.Reader, not Back_Compressed);
90
91 Stream.Buffer := new Buffer_Subtype;
92 Stream.Rest_First := Stream.Buffer'Last + 1;
93 end if;
94 end Create;
95
96 -----------
97 -- Flush --
98 -----------
99
100 procedure Flush
101 (Stream : in out Stream_Type;
102 Mode : in Flush_Mode := Sync_Flush)
103 is
104 Buffer : Stream_Element_Array (1 .. Stream.Buffer_Size);
105 Last : Stream_Element_Offset;
106 begin
107 loop
108 Flush (Stream.Writer, Buffer, Last, Mode);
109
110 Ada.Streams.Write (Stream.Back.all, Buffer (1 .. Last));
111
112 exit when Last < Buffer'Last;
113 end loop;
114 end Flush;
115
116 ----------
117 -- Read --
118 ----------
119
120 procedure Read
121 (Stream : in out Stream_Type;
122 Item : out Stream_Element_Array;
123 Last : out Stream_Element_Offset)
124 is
125
126 procedure Read
127 (Item : out Stream_Element_Array;
128 Last : out Stream_Element_Offset);
129
130 ----------
131 -- Read --
132 ----------
133
134 procedure Read
135 (Item : out Stream_Element_Array;
136 Last : out Stream_Element_Offset) is
137 begin
138 Ada.Streams.Read (Stream.Back.all, Item, Last);
139 end Read;
140
141 procedure Read is new ZLib.Read
142 (Read => Read,
143 Buffer => Stream.Buffer.all,
144 Rest_First => Stream.Rest_First,
145 Rest_Last => Stream.Rest_Last);
146
147 begin
148 Read (Stream.Reader, Item, Last);
149 end Read;
150
151 -------------------
152 -- Read_Total_In --
153 -------------------
154
155 function Read_Total_In (Stream : in Stream_Type) return Count is
156 begin
157 return Total_In (Stream.Reader);
158 end Read_Total_In;
159
160 --------------------
161 -- Read_Total_Out --
162 --------------------
163
164 function Read_Total_Out (Stream : in Stream_Type) return Count is
165 begin
166 return Total_Out (Stream.Reader);
167 end Read_Total_Out;
168
169 -----------
170 -- Write --
171 -----------
172
173 procedure Write
174 (Stream : in out Stream_Type;
175 Item : in Stream_Element_Array)
176 is
177
178 procedure Write (Item : in Stream_Element_Array);
179
180 -----------
181 -- Write --
182 -----------
183
184 procedure Write (Item : in Stream_Element_Array) is
185 begin
186 Ada.Streams.Write (Stream.Back.all, Item);
187 end Write;
188
189 procedure Write is new ZLib.Write
190 (Write => Write,
191 Buffer_Size => Stream.Buffer_Size);
192
193 begin
194 Write (Stream.Writer, Item, No_Flush);
195 end Write;
196
197 --------------------
198 -- Write_Total_In --
199 --------------------
200
201 function Write_Total_In (Stream : in Stream_Type) return Count is
202 begin
203 return Total_In (Stream.Writer);
204 end Write_Total_In;
205
206 ---------------------
207 -- Write_Total_Out --
208 ---------------------
209
210 function Write_Total_Out (Stream : in Stream_Type) return Count is
211 begin
212 return Total_Out (Stream.Writer);
213 end Write_Total_Out;
214
215end ZLib.Streams;
diff --git a/contrib/ada/zlib-streams.ads b/contrib/ada/zlib-streams.ads
new file mode 100644
index 0000000..1d5e904
--- /dev/null
+++ b/contrib/ada/zlib-streams.ads
@@ -0,0 +1,112 @@
1----------------------------------------------------------------
2-- ZLib for Ada thick binding. --
3-- --
4-- Copyright (C) 2002-2003 Dmitriy Anisimkov --
5-- --
6-- Open source license information is in the zlib.ads file. --
7----------------------------------------------------------------
8
9-- $Id: zlib-streams.ads,v 1.11 2003/08/12 13:15:31 vagul Exp $
10
11package ZLib.Streams is
12
13 type Stream_Mode is (In_Stream, Out_Stream, Duplex);
14
15 type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class;
16
17 type Stream_Type is
18 new Ada.Streams.Root_Stream_Type with private;
19
20 procedure Read
21 (Stream : in out Stream_Type;
22 Item : out Ada.Streams.Stream_Element_Array;
23 Last : out Ada.Streams.Stream_Element_Offset);
24
25 procedure Write
26 (Stream : in out Stream_Type;
27 Item : in Ada.Streams.Stream_Element_Array);
28
29 procedure Flush
30 (Stream : in out Stream_Type;
31 Mode : in Flush_Mode := Sync_Flush);
32 -- Flush the written data to the back stream,
33 -- all data placed to the compressor is flushing to the Back stream.
34 -- Should not be used untill necessary, becouse it is decreasing
35 -- compression.
36
37 function Read_Total_In (Stream : in Stream_Type) return Count;
38 pragma Inline (Read_Total_In);
39 -- Return total number of bytes read from back stream so far.
40
41 function Read_Total_Out (Stream : in Stream_Type) return Count;
42 pragma Inline (Read_Total_Out);
43 -- Return total number of bytes read so far.
44
45 function Write_Total_In (Stream : in Stream_Type) return Count;
46 pragma Inline (Write_Total_In);
47 -- Return total number of bytes written so far.
48
49 function Write_Total_Out (Stream : in Stream_Type) return Count;
50 pragma Inline (Write_Total_Out);
51 -- Return total number of bytes written to the back stream.
52
53 procedure Create
54 (Stream : out Stream_Type;
55 Mode : in Stream_Mode;
56 Back : in Stream_Access;
57 Back_Compressed : in Boolean;
58 Level : in Compression_Level := Default_Compression;
59 Strategy : in Strategy_Type := Default_Strategy;
60 Header : in Header_Type := Default;
61 Read_Buffer_Size : in Ada.Streams.Stream_Element_Offset
62 := Default_Buffer_Size;
63 Write_Buffer_Size : in Ada.Streams.Stream_Element_Offset
64 := Default_Buffer_Size);
65 -- Create the Comression/Decompression stream.
66 -- If mode is In_Stream then Write operation is disabled.
67 -- If mode is Out_Stream then Read operation is disabled.
68
69 -- If Back_Compressed is true then
70 -- Data written to the Stream is compressing to the Back stream
71 -- and data read from the Stream is decompressed data from the Back stream.
72
73 -- If Back_Compressed is false then
74 -- Data written to the Stream is decompressing to the Back stream
75 -- and data read from the Stream is compressed data from the Back stream.
76
77 -- !!! When the Need_Header is False ZLib-Ada is using undocumented
78 -- ZLib 1.1.4 functionality to do not create/wait for ZLib headers.
79
80 procedure Close (Stream : in out Stream_Type);
81
82private
83
84 use Ada.Streams;
85
86 type Buffer_Access is access all Stream_Element_Array;
87
88 type Stream_Type
89 is new Root_Stream_Type with
90 record
91 Mode : Stream_Mode;
92
93 Buffer : Buffer_Access;
94 Rest_First : Stream_Element_Offset;
95 Rest_Last : Stream_Element_Offset;
96 -- Buffer for Read operation.
97 -- We need to have this buffer in the record
98 -- becouse not all read data from back stream
99 -- could be processed during the read operation.
100
101 Buffer_Size : Stream_Element_Offset;
102 -- Buffer size for write operation.
103 -- We do not need to have this buffer
104 -- in the record becouse all data could be
105 -- processed in the write operation.
106
107 Back : Stream_Access;
108 Reader : Filter_Type;
109 Writer : Filter_Type;
110 end record;
111
112end ZLib.Streams;
diff --git a/contrib/ada/zlib-thin.adb b/contrib/ada/zlib-thin.adb
new file mode 100644
index 0000000..163bd5b
--- /dev/null
+++ b/contrib/ada/zlib-thin.adb
@@ -0,0 +1,185 @@
1----------------------------------------------------------------
2-- ZLib for Ada thick binding. --
3-- --
4-- Copyright (C) 2002-2003 Dmitriy Anisimkov --
5-- --
6-- Open source license information is in the zlib.ads file. --
7----------------------------------------------------------------
8
9-- $Id: zlib-thin.adb,v 1.6 2003/01/21 15:26:37 vagul Exp $
10
11package body ZLib.Thin is
12
13 ZLIB_VERSION : constant Chars_Ptr :=
14 Interfaces.C.Strings.New_String ("1.1.4");
15
16 Z_Stream_Size : constant Int := Z_Stream'Size / System.Storage_Unit;
17
18 --------------
19 -- Avail_In --
20 --------------
21
22 function Avail_In (Strm : in Z_Stream) return UInt is
23 begin
24 return Strm.Avail_In;
25 end Avail_In;
26
27 ---------------
28 -- Avail_Out --
29 ---------------
30
31 function Avail_Out (Strm : in Z_Stream) return UInt is
32 begin
33 return Strm.Avail_Out;
34 end Avail_Out;
35
36 ------------------
37 -- Deflate_Init --
38 ------------------
39
40 function Deflate_Init
41 (strm : in Z_Streamp;
42 level : in Int := Z_DEFAULT_COMPRESSION)
43 return Int is
44 begin
45 return deflateInit (strm, level, ZLIB_VERSION, Z_Stream_Size);
46 end Deflate_Init;
47
48 function Deflate_Init
49 (strm : Z_Streamp;
50 level : Int;
51 method : Int;
52 windowBits : Int;
53 memLevel : Int;
54 strategy : Int)
55 return Int is
56 begin
57 return deflateInit2
58 (strm,
59 level,
60 method,
61 windowBits,
62 memLevel,
63 strategy,
64 ZLIB_VERSION,
65 Z_Stream_Size);
66 end Deflate_Init;
67
68 ------------------
69 -- Inflate_Init --
70 ------------------
71
72 function Inflate_Init (strm : Z_Streamp) return Int is
73 begin
74 return inflateInit (strm, ZLIB_VERSION, Z_Stream_Size);
75 end Inflate_Init;
76
77 function Inflate_Init (strm : Z_Streamp; windowBits : Int) return Int is
78 begin
79 return inflateInit2 (strm, windowBits, ZLIB_VERSION, Z_Stream_Size);
80 end Inflate_Init;
81
82 function Last_Error_Message (Strm : in Z_Stream) return String is
83 use Interfaces.C.Strings;
84 begin
85 if Strm.msg = Null_Ptr then
86 return "";
87 else
88 return Value (Strm.msg);
89 end if;
90 end Last_Error_Message;
91
92 -------------
93 -- Need_In --
94 -------------
95
96 function Need_In (strm : Z_Stream) return Boolean is
97 begin
98 return strm.Avail_In = 0;
99 end Need_In;
100
101 --------------
102 -- Need_Out --
103 --------------
104
105 function Need_Out (strm : Z_Stream) return Boolean is
106 begin
107 return strm.Avail_Out = 0;
108 end Need_Out;
109
110 ------------
111 -- Set_In --
112 ------------
113
114 procedure Set_In
115 (Strm : in out Z_Stream;
116 Buffer : in Byte_Access;
117 Size : in UInt) is
118 begin
119 Strm.Next_In := Buffer;
120 Strm.Avail_In := Size;
121 end Set_In;
122
123 procedure Set_In
124 (Strm : in out Z_Stream;
125 Buffer : in Voidp;
126 Size : in UInt) is
127 begin
128 Set_In (Strm, Bytes.To_Pointer (Buffer), Size);
129 end Set_In;
130
131 ------------------
132 -- Set_Mem_Func --
133 ------------------
134
135 procedure Set_Mem_Func
136 (Strm : in out Z_Stream;
137 Opaque : in Voidp;
138 Alloc : in alloc_func;
139 Free : in free_func) is
140 begin
141 Strm.opaque := Opaque;
142 Strm.zalloc := Alloc;
143 Strm.zfree := Free;
144 end Set_Mem_Func;
145
146 -------------
147 -- Set_Out --
148 -------------
149
150 procedure Set_Out
151 (Strm : in out Z_Stream;
152 Buffer : in Byte_Access;
153 Size : in UInt) is
154 begin
155 Strm.Next_Out := Buffer;
156 Strm.Avail_Out := Size;
157 end Set_Out;
158
159 procedure Set_Out
160 (Strm : in out Z_Stream;
161 Buffer : in Voidp;
162 Size : in UInt) is
163 begin
164 Set_Out (Strm, Bytes.To_Pointer (Buffer), Size);
165 end Set_Out;
166
167 --------------
168 -- Total_In --
169 --------------
170
171 function Total_In (Strm : in Z_Stream) return ULong is
172 begin
173 return Strm.Total_In;
174 end Total_In;
175
176 ---------------
177 -- Total_Out --
178 ---------------
179
180 function Total_Out (Strm : in Z_Stream) return ULong is
181 begin
182 return Strm.Total_Out;
183 end Total_Out;
184
185end ZLib.Thin;
diff --git a/contrib/ada/zlib-thin.ads b/contrib/ada/zlib-thin.ads
new file mode 100644
index 0000000..19cbb96
--- /dev/null
+++ b/contrib/ada/zlib-thin.ads
@@ -0,0 +1,478 @@
1----------------------------------------------------------------
2-- ZLib for Ada thick binding. --
3-- --
4-- Copyright (C) 2002-2003 Dmitriy Anisimkov --
5-- --
6-- Open source license information is in the zlib.ads file. --
7----------------------------------------------------------------
8
9-- $Id: zlib-thin.ads,v 1.8 2003/08/12 13:16:51 vagul Exp $
10
11with Interfaces.C.Strings;
12with System.Address_To_Access_Conversions;
13
14private package ZLib.Thin is
15
16 -- From zconf.h
17
18 MAX_MEM_LEVEL : constant := 9; -- zconf.h:105
19 -- zconf.h:105
20 MAX_WBITS : constant := 15; -- zconf.h:115
21 -- 32K LZ77 window
22 -- zconf.h:115
23 SEEK_SET : constant := 8#0000#; -- zconf.h:244
24 -- Seek from beginning of file.
25 -- zconf.h:244
26 SEEK_CUR : constant := 1; -- zconf.h:245
27 -- Seek from current position.
28 -- zconf.h:245
29 SEEK_END : constant := 2; -- zconf.h:246
30 -- Set file pointer to EOF plus "offset"
31 -- zconf.h:246
32
33 type Byte is new Interfaces.C.unsigned_char; -- 8 bits
34 -- zconf.h:214
35 type UInt is new Interfaces.C.unsigned; -- 16 bits or more
36 -- zconf.h:216
37 type Int is new Interfaces.C.int;
38
39 type ULong is new Interfaces.C.unsigned; -- 32 bits or more
40 -- zconf.h:217
41 subtype Chars_Ptr is Interfaces.C.Strings.chars_ptr;
42
43 type ULong_Access is access ULong;
44 type Int_Access is access Int;
45 subtype Voidp is System.Address; -- zconf.h:232
46
47 package Bytes is new System.Address_To_Access_Conversions (Byte);
48
49 subtype Byte_Access is Bytes.Object_Pointer;
50
51 -- end from zconf
52
53 Z_NO_FLUSH : constant := 8#0000#; -- zlib.h:125
54 -- zlib.h:125
55 Z_PARTIAL_FLUSH : constant := 1; -- zlib.h:126
56 -- will be removed, use
57 -- Z_SYNC_FLUSH instead
58 -- zlib.h:126
59 Z_SYNC_FLUSH : constant := 2; -- zlib.h:127
60 -- zlib.h:127
61 Z_FULL_FLUSH : constant := 3; -- zlib.h:128
62 -- zlib.h:128
63 Z_FINISH : constant := 4; -- zlib.h:129
64 -- zlib.h:129
65 Z_OK : constant := 8#0000#; -- zlib.h:132
66 -- zlib.h:132
67 Z_STREAM_END : constant := 1; -- zlib.h:133
68 -- zlib.h:133
69 Z_NEED_DICT : constant := 2; -- zlib.h:134
70 -- zlib.h:134
71 Z_ERRNO : constant := -1; -- zlib.h:135
72 -- zlib.h:135
73 Z_STREAM_ERROR : constant := -2; -- zlib.h:136
74 -- zlib.h:136
75 Z_DATA_ERROR : constant := -3; -- zlib.h:137
76 -- zlib.h:137
77 Z_MEM_ERROR : constant := -4; -- zlib.h:138
78 -- zlib.h:138
79 Z_BUF_ERROR : constant := -5; -- zlib.h:139
80 -- zlib.h:139
81 Z_VERSION_ERROR : constant := -6; -- zlib.h:140
82 -- zlib.h:140
83 Z_NO_COMPRESSION : constant := 8#0000#; -- zlib.h:145
84 -- zlib.h:145
85 Z_BEST_SPEED : constant := 1; -- zlib.h:146
86 -- zlib.h:146
87 Z_BEST_COMPRESSION : constant := 9; -- zlib.h:147
88 -- zlib.h:147
89 Z_DEFAULT_COMPRESSION : constant := -1; -- zlib.h:148
90 -- zlib.h:148
91 Z_FILTERED : constant := 1; -- zlib.h:151
92 -- zlib.h:151
93 Z_HUFFMAN_ONLY : constant := 2; -- zlib.h:152
94 -- zlib.h:152
95 Z_DEFAULT_STRATEGY : constant := 8#0000#; -- zlib.h:153
96 -- zlib.h:153
97 Z_BINARY : constant := 8#0000#; -- zlib.h:156
98 -- zlib.h:156
99 Z_ASCII : constant := 1; -- zlib.h:157
100 -- zlib.h:157
101 Z_UNKNOWN : constant := 2; -- zlib.h:158
102 -- zlib.h:158
103 Z_DEFLATED : constant := 8; -- zlib.h:161
104 -- zlib.h:161
105 Z_NULL : constant := 8#0000#; -- zlib.h:164
106 -- for initializing zalloc, zfree, opaque
107 -- zlib.h:164
108 type gzFile is new Voidp; -- zlib.h:646
109
110 type Z_Stream is private;
111
112 type Z_Streamp is access all Z_Stream; -- zlib.h:89
113
114 type alloc_func is access function
115 (Opaque : Voidp;
116 Items : UInt;
117 Size : UInt)
118 return Voidp; -- zlib.h:63
119
120 type free_func is access procedure (opaque : Voidp; address : Voidp);
121
122 function zlibVersion return Chars_Ptr;
123
124 function Deflate (strm : Z_Streamp; flush : Int) return Int;
125
126 function DeflateEnd (strm : Z_Streamp) return Int;
127
128 function Inflate (strm : Z_Streamp; flush : Int) return Int;
129
130 function InflateEnd (strm : Z_Streamp) return Int;
131
132 function deflateSetDictionary
133 (strm : Z_Streamp;
134 dictionary : Byte_Access;
135 dictLength : UInt)
136 return Int;
137
138 function deflateCopy (dest : Z_Streamp; source : Z_Streamp) return Int;
139 -- zlib.h:478
140
141 function deflateReset (strm : Z_Streamp) return Int; -- zlib.h:495
142
143 function deflateParams
144 (strm : Z_Streamp;
145 level : Int;
146 strategy : Int)
147 return Int; -- zlib.h:506
148
149 function inflateSetDictionary
150 (strm : Z_Streamp;
151 dictionary : Byte_Access;
152 dictLength : UInt)
153 return Int; -- zlib.h:548
154
155 function inflateSync (strm : Z_Streamp) return Int; -- zlib.h:565
156
157 function inflateReset (strm : Z_Streamp) return Int; -- zlib.h:580
158
159 function compress
160 (dest : Byte_Access;
161 destLen : ULong_Access;
162 source : Byte_Access;
163 sourceLen : ULong)
164 return Int; -- zlib.h:601
165
166 function compress2
167 (dest : Byte_Access;
168 destLen : ULong_Access;
169 source : Byte_Access;
170 sourceLen : ULong;
171 level : Int)
172 return Int; -- zlib.h:615
173
174 function uncompress
175 (dest : Byte_Access;
176 destLen : ULong_Access;
177 source : Byte_Access;
178 sourceLen : ULong)
179 return Int;
180
181 function gzopen (path : Chars_Ptr; mode : Chars_Ptr) return gzFile;
182
183 function gzdopen (fd : Int; mode : Chars_Ptr) return gzFile;
184
185 function gzsetparams
186 (file : gzFile;
187 level : Int;
188 strategy : Int)
189 return Int;
190
191 function gzread
192 (file : gzFile;
193 buf : Voidp;
194 len : UInt)
195 return Int;
196
197 function gzwrite
198 (file : in gzFile;
199 buf : in Voidp;
200 len : in UInt)
201 return Int;
202
203 function gzprintf (file : in gzFile; format : in Chars_Ptr) return Int;
204
205 function gzputs (file : in gzFile; s : in Chars_Ptr) return Int;
206
207 function gzgets
208 (file : gzFile;
209 buf : Chars_Ptr;
210 len : Int)
211 return Chars_Ptr;
212
213 function gzputc (file : gzFile; char : Int) return Int;
214
215 function gzgetc (file : gzFile) return Int;
216
217 function gzflush (file : gzFile; flush : Int) return Int;
218
219 function gzseek
220 (file : gzFile;
221 offset : Int;
222 whence : Int)
223 return Int;
224
225 function gzrewind (file : gzFile) return Int;
226
227 function gztell (file : gzFile) return Int;
228
229 function gzeof (file : gzFile) return Int;
230
231 function gzclose (file : gzFile) return Int;
232
233 function gzerror (file : gzFile; errnum : Int_Access) return Chars_Ptr;
234
235 function adler32
236 (adler : ULong;
237 buf : Byte_Access;
238 len : UInt)
239 return ULong;
240
241 function crc32
242 (crc : ULong;
243 buf : Byte_Access;
244 len : UInt)
245 return ULong;
246
247 function deflateInit
248 (strm : Z_Streamp;
249 level : Int;
250 version : Chars_Ptr;
251 stream_size : Int)
252 return Int;
253
254 function Deflate_Init
255 (strm : in Z_Streamp;
256 level : in Int := Z_DEFAULT_COMPRESSION)
257 return Int;
258 pragma Inline (Deflate_Init);
259
260 function deflateInit2
261 (strm : Z_Streamp;
262 level : Int;
263 method : Int;
264 windowBits : Int;
265 memLevel : Int;
266 strategy : Int;
267 version : Chars_Ptr;
268 stream_size : Int)
269 return Int;
270
271 function Deflate_Init
272 (strm : Z_Streamp;
273 level : Int;
274 method : Int;
275 windowBits : Int;
276 memLevel : Int;
277 strategy : Int)
278 return Int;
279 pragma Inline (Deflate_Init);
280
281 function inflateInit
282 (strm : Z_Streamp;
283 version : Chars_Ptr;
284 stream_size : Int)
285 return Int;
286
287 function Inflate_Init (strm : Z_Streamp) return Int;
288 pragma Inline (Inflate_Init);
289
290 function inflateInit2
291 (strm : in Z_Streamp;
292 windowBits : in Int;
293 version : in Chars_Ptr;
294 stream_size : in Int)
295 return Int;
296
297 function inflateBackInit
298 (strm : in Z_Streamp;
299 windowBits : in Int;
300 window : in Byte_Access;
301 version : in Chars_Ptr;
302 stream_size : in Int)
303 return Int;
304 -- Size of window have to be 2**windowBits.
305
306 function Inflate_Init (strm : Z_Streamp; windowBits : Int) return Int;
307 pragma Inline (Inflate_Init);
308
309 function zError (err : Int) return Chars_Ptr;
310
311 function inflateSyncPoint (z : Z_Streamp) return Int;
312
313 function get_crc_table return ULong_Access;
314
315 -- Interface to the available fields of the z_stream structure.
316 -- The application must update next_in and avail_in when avail_in has
317 -- dropped to zero. It must update next_out and avail_out when avail_out
318 -- has dropped to zero. The application must initialize zalloc, zfree and
319 -- opaque before calling the init function.
320
321 function Need_In (strm : in Z_Stream) return Boolean;
322 -- return true when we do not need to setup Next_In and Avail_In fields.
323 pragma Inline (Need_In);
324
325 function Need_Out (strm : in Z_Stream) return Boolean;
326 -- return true when we do not need to setup Next_Out and Avail_Out field.
327 pragma Inline (Need_Out);
328
329 procedure Set_In
330 (Strm : in out Z_Stream;
331 Buffer : in Byte_Access;
332 Size : in UInt);
333 pragma Inline (Set_In);
334
335 procedure Set_In
336 (Strm : in out Z_Stream;
337 Buffer : in Voidp;
338 Size : in UInt);
339 pragma Inline (Set_In);
340
341 procedure Set_Out
342 (Strm : in out Z_Stream;
343 Buffer : in Byte_Access;
344 Size : in UInt);
345 pragma Inline (Set_Out);
346
347 procedure Set_Out
348 (Strm : in out Z_Stream;
349 Buffer : in Voidp;
350 Size : in UInt);
351 pragma Inline (Set_Out);
352
353 procedure Set_Mem_Func
354 (Strm : in out Z_Stream;
355 Opaque : in Voidp;
356 Alloc : in alloc_func;
357 Free : in free_func);
358 pragma Inline (Set_Mem_Func);
359
360 function Last_Error_Message (Strm : in Z_Stream) return String;
361 pragma Inline (Last_Error_Message);
362
363 function Avail_Out (Strm : in Z_Stream) return UInt;
364 pragma Inline (Avail_Out);
365
366 function Avail_In (Strm : in Z_Stream) return UInt;
367 pragma Inline (Avail_In);
368
369 function Total_In (Strm : in Z_Stream) return ULong;
370 pragma Inline (Total_In);
371
372 function Total_Out (Strm : in Z_Stream) return ULong;
373 pragma Inline (Total_Out);
374
375 function inflateCopy
376 (dest : in Z_Streamp;
377 Source : in Z_Streamp)
378 return Int;
379
380 function compressBound (Source_Len : in ULong) return ULong;
381
382 function deflateBound
383 (Strm : in Z_Streamp;
384 Source_Len : in ULong)
385 return ULong;
386
387 function gzungetc (C : in Int; File : in gzFile) return Int;
388
389 function zlibCompileFlags return ULong;
390
391private
392
393 type Z_Stream is record -- zlib.h:68
394 Next_In : Byte_Access; -- next input byte
395 Avail_In : UInt := 0; -- number of bytes available at next_in
396 Total_In : ULong := 0; -- total nb of input bytes read so far
397 Next_Out : Byte_Access; -- next output byte should be put there
398 Avail_Out : UInt := 0; -- remaining free space at next_out
399 Total_Out : ULong := 0; -- total nb of bytes output so far
400 msg : Chars_Ptr; -- last error message, NULL if no error
401 state : Voidp; -- not visible by applications
402 zalloc : alloc_func := null; -- used to allocate the internal state
403 zfree : free_func := null; -- used to free the internal state
404 opaque : Voidp; -- private data object passed to
405 -- zalloc and zfree
406 data_type : Int; -- best guess about the data type:
407 -- ascii or binary
408 adler : ULong; -- adler32 value of the uncompressed
409 -- data
410 reserved : ULong; -- reserved for future use
411 end record;
412
413 pragma Convention (C, Z_Stream);
414
415 pragma Import (C, zlibVersion, "zlibVersion");
416 pragma Import (C, Deflate, "deflate");
417 pragma Import (C, DeflateEnd, "deflateEnd");
418 pragma Import (C, Inflate, "inflate");
419 pragma Import (C, InflateEnd, "inflateEnd");
420 pragma Import (C, deflateSetDictionary, "deflateSetDictionary");
421 pragma Import (C, deflateCopy, "deflateCopy");
422 pragma Import (C, deflateReset, "deflateReset");
423 pragma Import (C, deflateParams, "deflateParams");
424 pragma Import (C, inflateSetDictionary, "inflateSetDictionary");
425 pragma Import (C, inflateSync, "inflateSync");
426 pragma Import (C, inflateReset, "inflateReset");
427 pragma Import (C, compress, "compress");
428 pragma Import (C, compress2, "compress2");
429 pragma Import (C, uncompress, "uncompress");
430 pragma Import (C, gzopen, "gzopen");
431 pragma Import (C, gzdopen, "gzdopen");
432 pragma Import (C, gzsetparams, "gzsetparams");
433 pragma Import (C, gzread, "gzread");
434 pragma Import (C, gzwrite, "gzwrite");
435 pragma Import (C, gzprintf, "gzprintf");
436 pragma Import (C, gzputs, "gzputs");
437 pragma Import (C, gzgets, "gzgets");
438 pragma Import (C, gzputc, "gzputc");
439 pragma Import (C, gzgetc, "gzgetc");
440 pragma Import (C, gzflush, "gzflush");
441 pragma Import (C, gzseek, "gzseek");
442 pragma Import (C, gzrewind, "gzrewind");
443 pragma Import (C, gztell, "gztell");
444 pragma Import (C, gzeof, "gzeof");
445 pragma Import (C, gzclose, "gzclose");
446 pragma Import (C, gzerror, "gzerror");
447 pragma Import (C, adler32, "adler32");
448 pragma Import (C, crc32, "crc32");
449 pragma Import (C, deflateInit, "deflateInit_");
450 pragma Import (C, inflateInit, "inflateInit_");
451 pragma Import (C, deflateInit2, "deflateInit2_");
452 pragma Import (C, inflateInit2, "inflateInit2_");
453 pragma Import (C, zError, "zError");
454 pragma Import (C, inflateSyncPoint, "inflateSyncPoint");
455 pragma Import (C, get_crc_table, "get_crc_table");
456
457 -- since zlib 1.2.0:
458
459 pragma Import (C, inflateCopy, "inflateCopy");
460 pragma Import (C, compressBound, "compressBound");
461 pragma Import (C, deflateBound, "deflateBound");
462 pragma Import (C, gzungetc, "gzungetc");
463 pragma Import (C, zlibCompileFlags, "zlibCompileFlags");
464
465 pragma Import (C, inflateBackInit, "inflateBackInit_");
466
467 -- I stopped binding the inflateBack routines, becouse realize that
468 -- it does not support zlib and gzip headers for now, and have no
469 -- symmetric deflateBack routines.
470 -- ZLib-Ada is symmetric regarding deflate/inflate data transformation
471 -- and has a similar generic callback interface for the
472 -- deflate/inflate transformation based on the regular Deflate/Inflate
473 -- routines.
474
475 -- pragma Import (C, inflateBack, "inflateBack");
476 -- pragma Import (C, inflateBackEnd, "inflateBackEnd");
477
478end ZLib.Thin;
diff --git a/contrib/ada/zlib.adb b/contrib/ada/zlib.adb
new file mode 100644
index 0000000..93bf885
--- /dev/null
+++ b/contrib/ada/zlib.adb
@@ -0,0 +1,674 @@
1----------------------------------------------------------------
2-- ZLib for Ada thick binding. --
3-- --
4-- Copyright (C) 2002-2003 Dmitriy Anisimkov --
5-- --
6-- Open source license information is in the zlib.ads file. --
7----------------------------------------------------------------
8
9-- $Id: zlib.adb,v 1.19 2003/07/13 16:02:19 vagul Exp $
10
11with Ada.Exceptions;
12with Ada.Unchecked_Conversion;
13with Ada.Unchecked_Deallocation;
14
15with Interfaces.C.Strings;
16
17with ZLib.Thin;
18
19package body ZLib is
20
21 use type Thin.Int;
22
23 type Z_Stream is new Thin.Z_Stream;
24
25 type Return_Code_Enum is
26 (OK,
27 STREAM_END,
28 NEED_DICT,
29 ERRNO,
30 STREAM_ERROR,
31 DATA_ERROR,
32 MEM_ERROR,
33 BUF_ERROR,
34 VERSION_ERROR);
35
36 type Flate_Step_Function is access
37 function (Strm : Thin.Z_Streamp; flush : Thin.Int) return Thin.Int;
38 pragma Convention (C, Flate_Step_Function);
39
40 type Flate_End_Function is access
41 function (Ctrm : in Thin.Z_Streamp) return Thin.Int;
42 pragma Convention (C, Flate_End_Function);
43
44 type Flate_Type is record
45 Step : Flate_Step_Function;
46 Done : Flate_End_Function;
47 end record;
48
49 subtype Footer_Array is Stream_Element_Array (1 .. 8);
50
51 Simple_GZip_Header : constant Stream_Element_Array (1 .. 10)
52 := (16#1f#, 16#8b#, -- Magic header
53 16#08#, -- Z_DEFLATED
54 16#00#, -- Flags
55 16#00#, 16#00#, 16#00#, 16#00#, -- Time
56 16#00#, -- XFlags
57 16#03# -- OS code
58 );
59 -- The simplest gzip header is not for informational, but just for
60 -- gzip format compatibility.
61 -- Note that some code below is using assumption
62 -- Simple_GZip_Header'Last > Footer_Array'Last, so do not make
63 -- Simple_GZip_Header'Last <= Footer_Array'Last.
64
65 Return_Code : constant array (Thin.Int range <>) of Return_Code_Enum
66 := (0 => OK,
67 1 => STREAM_END,
68 2 => NEED_DICT,
69 -1 => ERRNO,
70 -2 => STREAM_ERROR,
71 -3 => DATA_ERROR,
72 -4 => MEM_ERROR,
73 -5 => BUF_ERROR,
74 -6 => VERSION_ERROR);
75
76 Flate : constant array (Boolean) of Flate_Type
77 := (True => (Step => Thin.Deflate'Access,
78 Done => Thin.DeflateEnd'Access),
79 False => (Step => Thin.Inflate'Access,
80 Done => Thin.InflateEnd'Access));
81
82 Flush_Finish : constant array (Boolean) of Flush_Mode
83 := (True => Finish, False => No_Flush);
84
85 procedure Raise_Error (Stream : Z_Stream);
86 pragma Inline (Raise_Error);
87
88 procedure Raise_Error (Message : String);
89 pragma Inline (Raise_Error);
90
91 procedure Check_Error (Stream : Z_Stream; Code : Thin.Int);
92
93 procedure Free is new Ada.Unchecked_Deallocation
94 (Z_Stream, Z_Stream_Access);
95
96 function To_Thin_Access is new Ada.Unchecked_Conversion
97 (Z_Stream_Access, Thin.Z_Streamp);
98
99 procedure Translate_GZip
100 (Filter : in out Filter_Type;
101 In_Data : in Ada.Streams.Stream_Element_Array;
102 In_Last : out Ada.Streams.Stream_Element_Offset;
103 Out_Data : out Ada.Streams.Stream_Element_Array;
104 Out_Last : out Ada.Streams.Stream_Element_Offset;
105 Flush : in Flush_Mode);
106 -- Separate translate routine for make gzip header.
107
108 procedure Translate_Auto
109 (Filter : in out Filter_Type;
110 In_Data : in Ada.Streams.Stream_Element_Array;
111 In_Last : out Ada.Streams.Stream_Element_Offset;
112 Out_Data : out Ada.Streams.Stream_Element_Array;
113 Out_Last : out Ada.Streams.Stream_Element_Offset;
114 Flush : in Flush_Mode);
115 -- translate routine without additional headers.
116
117 -----------------
118 -- Check_Error --
119 -----------------
120
121 procedure Check_Error (Stream : Z_Stream; Code : Thin.Int) is
122 use type Thin.Int;
123 begin
124 if Code /= Thin.Z_OK then
125 Raise_Error
126 (Return_Code_Enum'Image (Return_Code (Code))
127 & ": " & Last_Error_Message (Stream));
128 end if;
129 end Check_Error;
130
131 -----------
132 -- Close --
133 -----------
134
135 procedure Close
136 (Filter : in out Filter_Type;
137 Ignore_Error : in Boolean := False)
138 is
139 Code : Thin.Int;
140 begin
141 Code := Flate (Filter.Compression).Done
142 (To_Thin_Access (Filter.Strm));
143
144 Filter.Opened := False;
145
146 if Ignore_Error or else Code = Thin.Z_OK then
147 Free (Filter.Strm);
148 else
149 declare
150 Error_Message : constant String
151 := Last_Error_Message (Filter.Strm.all);
152 begin
153 Free (Filter.Strm);
154 Ada.Exceptions.Raise_Exception
155 (ZLib_Error'Identity,
156 Return_Code_Enum'Image (Return_Code (Code))
157 & ": " & Error_Message);
158 end;
159 end if;
160 end Close;
161
162 -----------
163 -- CRC32 --
164 -----------
165
166 function CRC32
167 (CRC : in Unsigned_32;
168 Data : in Ada.Streams.Stream_Element_Array)
169 return Unsigned_32
170 is
171 use Thin;
172 begin
173 return Unsigned_32 (crc32
174 (ULong (CRC),
175 Bytes.To_Pointer (Data'Address),
176 Data'Length));
177 end CRC32;
178
179 procedure CRC32
180 (CRC : in out Unsigned_32;
181 Data : in Ada.Streams.Stream_Element_Array) is
182 begin
183 CRC := CRC32 (CRC, Data);
184 end CRC32;
185
186 ------------------
187 -- Deflate_Init --
188 ------------------
189
190 procedure Deflate_Init
191 (Filter : in out Filter_Type;
192 Level : in Compression_Level := Default_Compression;
193 Strategy : in Strategy_Type := Default_Strategy;
194 Method : in Compression_Method := Deflated;
195 Window_Bits : in Window_Bits_Type := 15;
196 Memory_Level : in Memory_Level_Type := 8;
197 Header : in Header_Type := Default)
198 is
199 use type Thin.Int;
200 Win_Bits : Thin.Int := Thin.Int (Window_Bits);
201 begin
202 -- We allow ZLib to make header only in case of default header type.
203 -- Otherwise we would either do header by ourselfs, or do not do
204 -- header at all.
205
206 if Header = None or else Header = GZip then
207 Win_Bits := -Win_Bits;
208 end if;
209
210 -- For the GZip CRC calculation and make headers.
211
212 if Header = GZip then
213 Filter.CRC := 0;
214 Filter.Offset := Simple_GZip_Header'First;
215 else
216 Filter.Offset := Simple_GZip_Header'Last + 1;
217 end if;
218
219 Filter.Strm := new Z_Stream;
220 Filter.Compression := True;
221 Filter.Stream_End := False;
222 Filter.Opened := True;
223 Filter.Header := Header;
224
225 if Thin.Deflate_Init
226 (To_Thin_Access (Filter.Strm),
227 Level => Thin.Int (Level),
228 method => Thin.Int (Method),
229 windowBits => Win_Bits,
230 memLevel => Thin.Int (Memory_Level),
231 strategy => Thin.Int (Strategy)) /= Thin.Z_OK
232 then
233 Raise_Error (Filter.Strm.all);
234 end if;
235 end Deflate_Init;
236
237 -----------
238 -- Flush --
239 -----------
240
241 procedure Flush
242 (Filter : in out Filter_Type;
243 Out_Data : out Ada.Streams.Stream_Element_Array;
244 Out_Last : out Ada.Streams.Stream_Element_Offset;
245 Flush : in Flush_Mode)
246 is
247 No_Data : Stream_Element_Array := (1 .. 0 => 0);
248 Last : Stream_Element_Offset;
249 begin
250 Translate (Filter, No_Data, Last, Out_Data, Out_Last, Flush);
251 end Flush;
252
253 -----------------------
254 -- Generic_Translate --
255 -----------------------
256
257 procedure Generic_Translate
258 (Filter : in out ZLib.Filter_Type;
259 In_Buffer_Size : Integer := Default_Buffer_Size;
260 Out_Buffer_Size : Integer := Default_Buffer_Size)
261 is
262 In_Buffer : Stream_Element_Array
263 (1 .. Stream_Element_Offset (In_Buffer_Size));
264 Out_Buffer : Stream_Element_Array
265 (1 .. Stream_Element_Offset (Out_Buffer_Size));
266 Last : Stream_Element_Offset;
267 In_Last : Stream_Element_Offset;
268 In_First : Stream_Element_Offset;
269 Out_Last : Stream_Element_Offset;
270 begin
271 Main : loop
272 Data_In (In_Buffer, Last);
273
274 In_First := In_Buffer'First;
275
276 loop
277 Translate
278 (Filter,
279 In_Buffer (In_First .. Last),
280 In_Last,
281 Out_Buffer,
282 Out_Last,
283 Flush_Finish (Last < In_Buffer'First));
284
285 Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last));
286
287 exit Main when Stream_End (Filter);
288
289 -- The end of in buffer.
290 exit when In_Last = Last;
291
292 In_First := In_Last + 1;
293 end loop;
294 end loop Main;
295
296 end Generic_Translate;
297
298 ------------------
299 -- Inflate_Init --
300 ------------------
301
302 procedure Inflate_Init
303 (Filter : in out Filter_Type;
304 Window_Bits : in Window_Bits_Type := 15;
305 Header : in Header_Type := Default)
306 is
307 use type Thin.Int;
308 Win_Bits : Thin.Int := Thin.Int (Window_Bits);
309
310 procedure Check_Version;
311 -- Check the latest header types compatibility.
312
313 procedure Check_Version is
314 begin
315 if Version <= "1.1.4" then
316 Raise_Error
317 ("Inflate header type " & Header_Type'Image (Header)
318 & " incompatible with ZLib version " & Version);
319 end if;
320 end Check_Version;
321
322 begin
323 case Header is
324 when None =>
325 Check_Version;
326
327 -- Inflate data without headers determined
328 -- by negative Win_Bits.
329
330 Win_Bits := -Win_Bits;
331 when GZip =>
332 Check_Version;
333
334 -- Inflate gzip data defined by flag 16.
335
336 Win_Bits := Win_Bits + 16;
337 when Auto =>
338 Check_Version;
339
340 -- Inflate with automatic detection
341 -- of gzip or native header defined by flag 32.
342
343 Win_Bits := Win_Bits + 32;
344 when Default => null;
345 end case;
346
347 Filter.Strm := new Z_Stream;
348 Filter.Compression := False;
349 Filter.Stream_End := False;
350 Filter.Opened := True;
351 Filter.Header := Header;
352
353 if Thin.Inflate_Init
354 (To_Thin_Access (Filter.Strm), Win_Bits) /= Thin.Z_OK
355 then
356 Raise_Error (Filter.Strm.all);
357 end if;
358 end Inflate_Init;
359
360 -----------------
361 -- Raise_Error --
362 -----------------
363
364 procedure Raise_Error (Message : String) is
365 begin
366 Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message);
367 end Raise_Error;
368
369 procedure Raise_Error (Stream : Z_Stream) is
370 begin
371 Raise_Error (Last_Error_Message (Stream));
372 end Raise_Error;
373
374 ----------
375 -- Read --
376 ----------
377
378 procedure Read
379 (Filter : in out Filter_Type;
380 Item : out Ada.Streams.Stream_Element_Array;
381 Last : out Ada.Streams.Stream_Element_Offset)
382 is
383 In_Last : Stream_Element_Offset;
384 Item_First : Ada.Streams.Stream_Element_Offset := Item'First;
385
386 begin
387 pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1);
388
389 loop
390 if Rest_First > Buffer'Last then
391 Read (Buffer, Rest_Last);
392 Rest_First := Buffer'First;
393 end if;
394
395 pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last);
396
397 Translate
398 (Filter => Filter,
399 In_Data => Buffer (Rest_First .. Rest_Last),
400 In_Last => In_Last,
401 Out_Data => Item (Item_First .. Item'Last),
402 Out_Last => Last,
403 Flush => Flush_Finish (Rest_Last < Rest_First));
404
405 Rest_First := In_Last + 1;
406
407 exit when Last = Item'Last or else Stream_End (Filter);
408
409 Item_First := Last + 1;
410 end loop;
411 end Read;
412
413 ----------------
414 -- Stream_End --
415 ----------------
416
417 function Stream_End (Filter : in Filter_Type) return Boolean is
418 begin
419 if Filter.Header = GZip and Filter.Compression then
420 return Filter.Stream_End
421 and then Filter.Offset = Footer_Array'Last + 1;
422 else
423 return Filter.Stream_End;
424 end if;
425 end Stream_End;
426
427 --------------
428 -- Total_In --
429 --------------
430
431 function Total_In (Filter : in Filter_Type) return Count is
432 begin
433 return Count (Thin.Total_In (To_Thin_Access (Filter.Strm).all));
434 end Total_In;
435
436 ---------------
437 -- Total_Out --
438 ---------------
439
440 function Total_Out (Filter : in Filter_Type) return Count is
441 begin
442 return Count (Thin.Total_Out (To_Thin_Access (Filter.Strm).all));
443 end Total_Out;
444
445 ---------------
446 -- Translate --
447 ---------------
448
449 procedure Translate
450 (Filter : in out Filter_Type;
451 In_Data : in Ada.Streams.Stream_Element_Array;
452 In_Last : out Ada.Streams.Stream_Element_Offset;
453 Out_Data : out Ada.Streams.Stream_Element_Array;
454 Out_Last : out Ada.Streams.Stream_Element_Offset;
455 Flush : in Flush_Mode) is
456 begin
457 if Filter.Header = GZip and then Filter.Compression then
458 Translate_GZip
459 (Filter => Filter,
460 In_Data => In_Data,
461 In_Last => In_Last,
462 Out_Data => Out_Data,
463 Out_Last => Out_Last,
464 Flush => Flush);
465 else
466 Translate_Auto
467 (Filter => Filter,
468 In_Data => In_Data,
469 In_Last => In_Last,
470 Out_Data => Out_Data,
471 Out_Last => Out_Last,
472 Flush => Flush);
473 end if;
474 end Translate;
475
476 --------------------
477 -- Translate_Auto --
478 --------------------
479
480 procedure Translate_Auto
481 (Filter : in out Filter_Type;
482 In_Data : in Ada.Streams.Stream_Element_Array;
483 In_Last : out Ada.Streams.Stream_Element_Offset;
484 Out_Data : out Ada.Streams.Stream_Element_Array;
485 Out_Last : out Ada.Streams.Stream_Element_Offset;
486 Flush : in Flush_Mode)
487 is
488 use type Thin.Int;
489 Code : Thin.Int;
490
491 begin
492 if Filter.Opened = False then
493 raise ZLib_Error;
494 end if;
495
496 if Out_Data'Length = 0 then
497 raise Constraint_Error;
498 end if;
499
500 Set_Out (Filter.Strm.all, Out_Data'Address, Out_Data'Length);
501 Set_In (Filter.Strm.all, In_Data'Address, In_Data'Length);
502
503 Code := Flate (Filter.Compression).Step
504 (To_Thin_Access (Filter.Strm),
505 Thin.Int (Flush));
506
507 if Code = Thin.Z_STREAM_END then
508 Filter.Stream_End := True;
509 else
510 Check_Error (Filter.Strm.all, Code);
511 end if;
512
513 In_Last := In_Data'Last
514 - Stream_Element_Offset (Avail_In (Filter.Strm.all));
515 Out_Last := Out_Data'Last
516 - Stream_Element_Offset (Avail_Out (Filter.Strm.all));
517
518 end Translate_Auto;
519
520 --------------------
521 -- Translate_GZip --
522 --------------------
523
524 procedure Translate_GZip
525 (Filter : in out Filter_Type;
526 In_Data : in Ada.Streams.Stream_Element_Array;
527 In_Last : out Ada.Streams.Stream_Element_Offset;
528 Out_Data : out Ada.Streams.Stream_Element_Array;
529 Out_Last : out Ada.Streams.Stream_Element_Offset;
530 Flush : in Flush_Mode)
531 is
532 Out_First : Stream_Element_Offset;
533
534 procedure Add_Data (Data : in Stream_Element_Array);
535 -- Add data to stream from the Filter.Offset till necessary,
536 -- used for add gzip headr/footer.
537
538 procedure Put_32
539 (Item : in out Stream_Element_Array;
540 Data : in Unsigned_32);
541 pragma Inline (Put_32);
542
543 --------------
544 -- Add_Data --
545 --------------
546
547 procedure Add_Data (Data : in Stream_Element_Array) is
548 Data_First : Stream_Element_Offset renames Filter.Offset;
549 Data_Last : Stream_Element_Offset;
550 Data_Len : Stream_Element_Offset; -- -1
551 Out_Len : Stream_Element_Offset; -- -1
552 begin
553 Out_First := Out_Last + 1;
554
555 if Data_First > Data'Last then
556 return;
557 end if;
558
559 Data_Len := Data'Last - Data_First;
560 Out_Len := Out_Data'Last - Out_First;
561
562 if Data_Len <= Out_Len then
563 Out_Last := Out_First + Data_Len;
564 Data_Last := Data'Last;
565 else
566 Out_Last := Out_Data'Last;
567 Data_Last := Data_First + Out_Len;
568 end if;
569
570 Out_Data (Out_First .. Out_Last) := Data (Data_First .. Data_Last);
571
572 Data_First := Data_Last + 1;
573 Out_First := Out_Last + 1;
574 end Add_Data;
575
576 ------------
577 -- Put_32 --
578 ------------
579
580 procedure Put_32
581 (Item : in out Stream_Element_Array;
582 Data : in Unsigned_32)
583 is
584 D : Unsigned_32 := Data;
585 begin
586 for J in Item'First .. Item'First + 3 loop
587 Item (J) := Stream_Element (D and 16#FF#);
588 D := Shift_Right (D, 8);
589 end loop;
590 end Put_32;
591
592 begin
593 Out_Last := Out_Data'First - 1;
594
595 if not Filter.Stream_End then
596 Add_Data (Simple_GZip_Header);
597
598 Translate_Auto
599 (Filter => Filter,
600 In_Data => In_Data,
601 In_Last => In_Last,
602 Out_Data => Out_Data (Out_First .. Out_Data'Last),
603 Out_Last => Out_Last,
604 Flush => Flush);
605
606 CRC32 (Filter.CRC, In_Data (In_Data'First .. In_Last));
607
608 end if;
609
610 if Filter.Stream_End and then Out_Last <= Out_Data'Last then
611 -- This detection method would work only when
612 -- Simple_GZip_Header'Last > Footer_Array'Last
613
614 if Filter.Offset = Simple_GZip_Header'Last + 1 then
615 Filter.Offset := Footer_Array'First;
616 end if;
617
618 declare
619 Footer : Footer_Array;
620 begin
621 Put_32 (Footer, Filter.CRC);
622 Put_32 (Footer (Footer'First + 4 .. Footer'Last),
623 Unsigned_32 (Total_In (Filter)));
624 Add_Data (Footer);
625 end;
626 end if;
627 end Translate_GZip;
628
629 -------------
630 -- Version --
631 -------------
632
633 function Version return String is
634 begin
635 return Interfaces.C.Strings.Value (Thin.zlibVersion);
636 end Version;
637
638 -----------
639 -- Write --
640 -----------
641
642 procedure Write
643 (Filter : in out Filter_Type;
644 Item : in Ada.Streams.Stream_Element_Array;
645 Flush : in Flush_Mode)
646 is
647 Buffer : Stream_Element_Array (1 .. Buffer_Size);
648 In_Last, Out_Last : Stream_Element_Offset;
649 In_First : Stream_Element_Offset := Item'First;
650 begin
651 if Item'Length = 0 and Flush = No_Flush then
652 return;
653 end if;
654
655 loop
656 Translate
657 (Filter => Filter,
658 In_Data => Item (In_First .. Item'Last),
659 In_Last => In_Last,
660 Out_Data => Buffer,
661 Out_Last => Out_Last,
662 Flush => Flush);
663
664 if Out_Last >= Buffer'First then
665 Write (Buffer (1 .. Out_Last));
666 end if;
667
668 exit when In_Last = Item'Last or Stream_End (Filter);
669
670 In_First := In_Last + 1;
671 end loop;
672 end Write;
673
674end ZLib;
diff --git a/contrib/ada/zlib.ads b/contrib/ada/zlib.ads
new file mode 100644
index 0000000..b72e4d2
--- /dev/null
+++ b/contrib/ada/zlib.ads
@@ -0,0 +1,311 @@
1------------------------------------------------------------------------------
2-- ZLib for Ada thick binding. --
3-- --
4-- Copyright (C) 2002-2003 Dmitriy Anisimkov --
5-- --
6-- This library is free software; you can redistribute it and/or modify --
7-- it under the terms of the GNU General Public License as published by --
8-- the Free Software Foundation; either version 2 of the License, or (at --
9-- your option) any later version. --
10-- --
11-- This library is distributed in the hope that it will be useful, but --
12-- WITHOUT ANY WARRANTY; without even the implied warranty of --
13-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
14-- General Public License for more details. --
15-- --
16-- You should have received a copy of the GNU General Public License --
17-- along with this library; if not, write to the Free Software Foundation, --
18-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
19-- --
20-- As a special exception, if other files instantiate generics from this --
21-- unit, or you link this unit with other files to produce an executable, --
22-- this unit does not by itself cause the resulting executable to be --
23-- covered by the GNU General Public License. This exception does not --
24-- however invalidate any other reasons why the executable file might be --
25-- covered by the GNU Public License. --
26------------------------------------------------------------------------------
27
28-- $Id: zlib.ads,v 1.17 2003/08/12 13:19:07 vagul Exp $
29
30with Ada.Streams;
31
32with Interfaces;
33
34package ZLib is
35
36 ZLib_Error : exception;
37
38 type Compression_Level is new Integer range -1 .. 9;
39
40 type Flush_Mode is private;
41
42 type Compression_Method is private;
43
44 type Window_Bits_Type is new Integer range 8 .. 15;
45
46 type Memory_Level_Type is new Integer range 1 .. 9;
47
48 type Unsigned_32 is new Interfaces.Unsigned_32;
49
50 type Strategy_Type is private;
51
52 type Header_Type is (None, Auto, Default, GZip);
53 -- Header type usage have a some limitation for inflate.
54 -- See comment for Inflate_Init.
55
56 subtype Count is Ada.Streams.Stream_Element_Count;
57
58 ----------------------------------
59 -- Compression method constants --
60 ----------------------------------
61
62 Deflated : constant Compression_Method;
63 -- Only one method allowed in this ZLib version.
64
65 ---------------------------------
66 -- Compression level constants --
67 ---------------------------------
68
69 No_Compression : constant Compression_Level := 0;
70 Best_Speed : constant Compression_Level := 1;
71 Best_Compression : constant Compression_Level := 9;
72 Default_Compression : constant Compression_Level := -1;
73
74 --------------------------
75 -- Flush mode constants --
76 --------------------------
77
78 No_Flush : constant Flush_Mode;
79 -- Regular way for compression, no flush
80
81 Partial_Flush : constant Flush_Mode;
82 -- will be removed, use Z_SYNC_FLUSH instead
83
84 Sync_Flush : constant Flush_Mode;
85 -- all pending output is flushed to the output buffer and the output
86 -- is aligned on a byte boundary, so that the decompressor can get all
87 -- input data available so far. (In particular avail_in is zero after the
88 -- call if enough output space has been provided before the call.)
89 -- Flushing may degrade compression for some compression algorithms and so
90 -- it should be used only when necessary.
91
92 Full_Flush : constant Flush_Mode;
93 -- all output is flushed as with SYNC_FLUSH, and the compression state
94 -- is reset so that decompression can restart from this point if previous
95 -- compressed data has been damaged or if random access is desired. Using
96 -- FULL_FLUSH too often can seriously degrade the compression.
97
98 Finish : constant Flush_Mode;
99 -- Just for tell the compressor that input data is complete.
100
101 ------------------------------------
102 -- Compression strategy constants --
103 ------------------------------------
104
105 -- RLE stategy could be used only in version 1.2.0 and later.
106
107 Filtered : constant Strategy_Type;
108 Huffman_Only : constant Strategy_Type;
109 RLE : constant Strategy_Type;
110 Default_Strategy : constant Strategy_Type;
111
112 Default_Buffer_Size : constant := 4096;
113
114 type Filter_Type is limited private;
115 -- The filter is for compression and for decompression.
116 -- The usage of the type is depend of its initialization.
117
118 function Version return String;
119 pragma Inline (Version);
120 -- Return string representation of the ZLib version.
121
122 procedure Deflate_Init
123 (Filter : in out Filter_Type;
124 Level : in Compression_Level := Default_Compression;
125 Strategy : in Strategy_Type := Default_Strategy;
126 Method : in Compression_Method := Deflated;
127 Window_Bits : in Window_Bits_Type := 15;
128 Memory_Level : in Memory_Level_Type := 8;
129 Header : in Header_Type := Default);
130 -- Compressor initialization.
131 -- When Header parameter is Auto or Default, then default zlib header
132 -- would be provided for compressed data.
133 -- When Header is GZip, then gzip header would be set instead of
134 -- default header.
135 -- When Header is None, no header would be set for compressed data.
136
137 procedure Inflate_Init
138 (Filter : in out Filter_Type;
139 Window_Bits : in Window_Bits_Type := 15;
140 Header : in Header_Type := Default);
141 -- Decompressor initialization.
142 -- Default header type mean that ZLib default header is expecting in the
143 -- input compressed stream.
144 -- Header type None mean that no header is expecting in the input stream.
145 -- GZip header type mean that GZip header is expecting in the
146 -- input compressed stream.
147 -- Auto header type mean that header type (GZip or Native) would be
148 -- detected automatically in the input stream.
149 -- Note that header types parameter values None, GZip and Auto is
150 -- supporting for inflate routine only in ZLib versions 1.2.0.2 and later.
151 -- Deflate_Init is supporting all header types.
152
153 procedure Close
154 (Filter : in out Filter_Type;
155 Ignore_Error : in Boolean := False);
156 -- Closing the compression or decompressor.
157 -- If stream is closing before the complete and Ignore_Error is False,
158 -- The exception would be raised.
159
160 generic
161 with procedure Data_In
162 (Item : out Ada.Streams.Stream_Element_Array;
163 Last : out Ada.Streams.Stream_Element_Offset);
164 with procedure Data_Out
165 (Item : in Ada.Streams.Stream_Element_Array);
166 procedure Generic_Translate
167 (Filter : in out Filter_Type;
168 In_Buffer_Size : in Integer := Default_Buffer_Size;
169 Out_Buffer_Size : in Integer := Default_Buffer_Size);
170 -- Compressing/decompressing data arrived from Data_In routine
171 -- to the Data_Out routine. User should provide Data_In and Data_Out
172 -- for compression/decompression data flow.
173 -- Compression or decompression depend on initialization of Filter.
174
175 function Total_In (Filter : in Filter_Type) return Count;
176 pragma Inline (Total_In);
177 -- Return total number of input bytes read so far.
178
179 function Total_Out (Filter : in Filter_Type) return Count;
180 pragma Inline (Total_Out);
181 -- Return total number of bytes output so far.
182
183 function CRC32
184 (CRC : in Unsigned_32;
185 Data : in Ada.Streams.Stream_Element_Array)
186 return Unsigned_32;
187 pragma Inline (CRC32);
188 -- Calculate CRC32, it could be necessary for make gzip format.
189
190 procedure CRC32
191 (CRC : in out Unsigned_32;
192 Data : in Ada.Streams.Stream_Element_Array);
193 pragma Inline (CRC32);
194 -- Calculate CRC32, it could be necessary for make gzip format.
195
196 -------------------------------------------------
197 -- Below is more complex low level routines. --
198 -------------------------------------------------
199
200 procedure Translate
201 (Filter : in out Filter_Type;
202 In_Data : in Ada.Streams.Stream_Element_Array;
203 In_Last : out Ada.Streams.Stream_Element_Offset;
204 Out_Data : out Ada.Streams.Stream_Element_Array;
205 Out_Last : out Ada.Streams.Stream_Element_Offset;
206 Flush : in Flush_Mode);
207 -- Compressing/decompressing the datas from In_Data buffer to the
208 -- Out_Data buffer.
209 -- In_Data is incoming data portion,
210 -- In_Last is the index of last element from In_Data accepted by the
211 -- Filter.
212 -- Out_Data is the buffer for output data from the filter.
213 -- Out_Last is the last element of the received data from Filter.
214 -- To tell the filter that incoming data is complete put the
215 -- Flush parameter to FINISH.
216
217 function Stream_End (Filter : in Filter_Type) return Boolean;
218 pragma Inline (Stream_End);
219 -- Return the true when the stream is complete.
220
221 procedure Flush
222 (Filter : in out Filter_Type;
223 Out_Data : out Ada.Streams.Stream_Element_Array;
224 Out_Last : out Ada.Streams.Stream_Element_Offset;
225 Flush : in Flush_Mode);
226 pragma Inline (Flush);
227 -- Flushing the data from the compressor.
228
229 generic
230 with procedure Write
231 (Item : in Ada.Streams.Stream_Element_Array);
232 -- User should provide this routine for accept
233 -- compressed/decompressed data.
234
235 Buffer_Size : in Ada.Streams.Stream_Element_Offset
236 := Default_Buffer_Size;
237 -- Buffer size for Write user routine.
238
239 procedure Write
240 (Filter : in out Filter_Type;
241 Item : in Ada.Streams.Stream_Element_Array;
242 Flush : in Flush_Mode);
243 -- Compressing/Decompressing data from Item to the
244 -- generic parameter procedure Write.
245 -- Output buffer size could be set in Buffer_Size generic parameter.
246
247 generic
248 with procedure Read
249 (Item : out Ada.Streams.Stream_Element_Array;
250 Last : out Ada.Streams.Stream_Element_Offset);
251 -- User should provide data for compression/decompression
252 -- thru this routine.
253
254 Buffer : in out Ada.Streams.Stream_Element_Array;
255 -- Buffer for keep remaining data from the previous
256 -- back read.
257
258 Rest_First, Rest_Last : in out Ada.Streams.Stream_Element_Offset;
259 -- Rest_First have to be initialized to Buffer'Last + 1
260 -- before usage.
261
262 procedure Read
263 (Filter : in out Filter_Type;
264 Item : out Ada.Streams.Stream_Element_Array;
265 Last : out Ada.Streams.Stream_Element_Offset);
266 -- Compressing/Decompressing data from generic parameter
267 -- procedure Read to the Item.
268 -- User should provide Buffer for the operation
269 -- and Rest_First variable first time initialized to the Buffer'Last + 1.
270
271private
272
273 use Ada.Streams;
274
275 type Flush_Mode is new Integer range 0 .. 4;
276
277 type Compression_Method is new Integer range 8 .. 8;
278
279 type Strategy_Type is new Integer range 0 .. 3;
280
281 No_Flush : constant Flush_Mode := 0;
282 Sync_Flush : constant Flush_Mode := 2;
283 Full_Flush : constant Flush_Mode := 3;
284 Finish : constant Flush_Mode := 4;
285 Partial_Flush : constant Flush_Mode := 1;
286 -- will be removed, use Z_SYNC_FLUSH instead
287
288 Filtered : constant Strategy_Type := 1;
289 Huffman_Only : constant Strategy_Type := 2;
290 RLE : constant Strategy_Type := 3;
291 Default_Strategy : constant Strategy_Type := 0;
292
293 Deflated : constant Compression_Method := 8;
294
295 type Z_Stream;
296
297 type Z_Stream_Access is access all Z_Stream;
298
299 type Filter_Type is record
300 Strm : Z_Stream_Access;
301 Compression : Boolean;
302 Stream_End : Boolean;
303 Header : Header_Type;
304 CRC : Unsigned_32;
305 Offset : Stream_Element_Offset;
306 -- Offset for gzip header/footer output.
307
308 Opened : Boolean := False;
309 end record;
310
311end ZLib;
diff --git a/contrib/ada/zlib.gpr b/contrib/ada/zlib.gpr
new file mode 100644
index 0000000..0f58985
--- /dev/null
+++ b/contrib/ada/zlib.gpr
@@ -0,0 +1,21 @@
1project Zlib is
2
3 for Languages use ("Ada");
4 for Source_Dirs use (".");
5 for Object_Dir use ".";
6 for Main use ("test.adb", "mtest.adb", "read.adb");
7
8 package Compiler is
9 for Default_Switches ("ada") use ("-gnatwbcfilopru", "-gnatVcdfimorst", "-gnatyabcefhiklmnoprst");
10 end Compiler;
11
12 package Linker is
13 for Default_Switches ("ada") use ("-lz");
14 end Linker;
15
16 package Builder is
17 for Default_Switches ("ada") use ("-s", "-gnatQ");
18 end Builder;
19
20end Zlib;
21
generated by cgit v1.2.3-55-g6feb (git 2.39.1) at 2025-12-28 15:44:42 +0000