Mercurial > hg > sv-dependency-builds

comparison src/zlib-1.2.7/contrib/ada/zlib.adb @ 4:e13257ea84a4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add bzip2, zlib, liblo, portaudio sources
author Chris Cannam
date Wed, 20 Mar 2013 13:59:52 +0000
parents
children
comparison
equal deleted inserted replaced
3:6c505a35919a 4:e13257ea84a4
1 ----------------------------------------------------------------
2 -- ZLib for Ada thick binding. --
3 -- --
4 -- Copyright (C) 2002-2004 Dmitriy Anisimkov --
5 -- --
6 -- Open source license information is in the zlib.ads file. --
7 ----------------------------------------------------------------
8
9 -- $Id: zlib.adb,v 1.31 2004/09/06 06:53:19 vagul Exp $
10
11 with Ada.Exceptions;
12 with Ada.Unchecked_Conversion;
13 with Ada.Unchecked_Deallocation;
14
15 with Interfaces.C.Strings;
16
17 with ZLib.Thin;
18
19 package 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 : in Thin.Z_Streamp; Flush : in 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 : in Z_Stream);
86 pragma Inline (Raise_Error);
87
88 procedure Raise_Error (Message : in String);
89 pragma Inline (Raise_Error);
90
91 procedure Check_Error (Stream : in Z_Stream; Code : in 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 : in Z_Stream; Code : in 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 if not Ignore_Error and then not Is_Open (Filter) then
142 raise Status_Error;
143 end if;
144
145 Code := Flate (Filter.Compression).Done (To_Thin_Access (Filter.Strm));
146
147 if Ignore_Error or else Code = Thin.Z_OK then
148 Free (Filter.Strm);
149 else
150 declare
151 Error_Message : constant String
152 := Last_Error_Message (Filter.Strm.all);
153 begin
154 Free (Filter.Strm);
155 Ada.Exceptions.Raise_Exception
156 (ZLib_Error'Identity,
157 Return_Code_Enum'Image (Return_Code (Code))
158 & ": " & Error_Message);
159 end;
160 end if;
161 end Close;
162
163 -----------
164 -- CRC32 --
165 -----------
166
167 function CRC32
168 (CRC : in Unsigned_32;
169 Data : in Ada.Streams.Stream_Element_Array)
170 return Unsigned_32
171 is
172 use Thin;
173 begin
174 return Unsigned_32 (crc32 (ULong (CRC),
175 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 := Default_Window_Bits;
196 Memory_Level : in Memory_Level_Type := Default_Memory_Level;
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 if Is_Open (Filter) then
203 raise Status_Error;
204 end if;
205
206 -- We allow ZLib to make header only in case of default header type.
207 -- Otherwise we would either do header by ourselfs, or do not do
208 -- header at all.
209
210 if Header = None or else Header = GZip then
211 Win_Bits := -Win_Bits;
212 end if;
213
214 -- For the GZip CRC calculation and make headers.
215
216 if Header = GZip then
217 Filter.CRC := 0;
218 Filter.Offset := Simple_GZip_Header'First;
219 else
220 Filter.Offset := Simple_GZip_Header'Last + 1;
221 end if;
222
223 Filter.Strm := new Z_Stream;
224 Filter.Compression := True;
225 Filter.Stream_End := False;
226 Filter.Header := Header;
227
228 if Thin.Deflate_Init
229 (To_Thin_Access (Filter.Strm),
230 Level => Thin.Int (Level),
231 method => Thin.Int (Method),
232 windowBits => Win_Bits,
233 memLevel => Thin.Int (Memory_Level),
234 strategy => Thin.Int (Strategy)) /= Thin.Z_OK
235 then
236 Raise_Error (Filter.Strm.all);
237 end if;
238 end Deflate_Init;
239
240 -----------
241 -- Flush --
242 -----------
243
244 procedure Flush
245 (Filter : in out Filter_Type;
246 Out_Data : out Ada.Streams.Stream_Element_Array;
247 Out_Last : out Ada.Streams.Stream_Element_Offset;
248 Flush : in Flush_Mode)
249 is
250 No_Data : Stream_Element_Array := (1 .. 0 => 0);
251 Last : Stream_Element_Offset;
252 begin
253 Translate (Filter, No_Data, Last, Out_Data, Out_Last, Flush);
254 end Flush;
255
256 -----------------------
257 -- Generic_Translate --
258 -----------------------
259
260 procedure Generic_Translate
261 (Filter : in out ZLib.Filter_Type;
262 In_Buffer_Size : in Integer := Default_Buffer_Size;
263 Out_Buffer_Size : in Integer := Default_Buffer_Size)
264 is
265 In_Buffer : Stream_Element_Array
266 (1 .. Stream_Element_Offset (In_Buffer_Size));
267 Out_Buffer : Stream_Element_Array
268 (1 .. Stream_Element_Offset (Out_Buffer_Size));
269 Last : Stream_Element_Offset;
270 In_Last : Stream_Element_Offset;
271 In_First : Stream_Element_Offset;
272 Out_Last : Stream_Element_Offset;
273 begin
274 Main : loop
275 Data_In (In_Buffer, Last);
276
277 In_First := In_Buffer'First;
278
279 loop
280 Translate
281 (Filter => Filter,
282 In_Data => In_Buffer (In_First .. Last),
283 In_Last => In_Last,
284 Out_Data => Out_Buffer,
285 Out_Last => Out_Last,
286 Flush => Flush_Finish (Last < In_Buffer'First));
287
288 if Out_Buffer'First <= Out_Last then
289 Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last));
290 end if;
291
292 exit Main when Stream_End (Filter);
293
294 -- The end of in buffer.
295
296 exit when In_Last = Last;
297
298 In_First := In_Last + 1;
299 end loop;
300 end loop Main;
301
302 end Generic_Translate;
303
304 ------------------
305 -- Inflate_Init --
306 ------------------
307
308 procedure Inflate_Init
309 (Filter : in out Filter_Type;
310 Window_Bits : in Window_Bits_Type := Default_Window_Bits;
311 Header : in Header_Type := Default)
312 is
313 use type Thin.Int;
314 Win_Bits : Thin.Int := Thin.Int (Window_Bits);
315
316 procedure Check_Version;
317 -- Check the latest header types compatibility.
318
319 procedure Check_Version is
320 begin
321 if Version <= "1.1.4" then
322 Raise_Error
323 ("Inflate header type " & Header_Type'Image (Header)
324 & " incompatible with ZLib version " & Version);
325 end if;
326 end Check_Version;
327
328 begin
329 if Is_Open (Filter) then
330 raise Status_Error;
331 end if;
332
333 case Header is
334 when None =>
335 Check_Version;
336
337 -- Inflate data without headers determined
338 -- by negative Win_Bits.
339
340 Win_Bits := -Win_Bits;
341 when GZip =>
342 Check_Version;
343
344 -- Inflate gzip data defined by flag 16.
345
346 Win_Bits := Win_Bits + 16;
347 when Auto =>
348 Check_Version;
349
350 -- Inflate with automatic detection
351 -- of gzip or native header defined by flag 32.
352
353 Win_Bits := Win_Bits + 32;
354 when Default => null;
355 end case;
356
357 Filter.Strm := new Z_Stream;
358 Filter.Compression := False;
359 Filter.Stream_End := False;
360 Filter.Header := Header;
361
362 if Thin.Inflate_Init
363 (To_Thin_Access (Filter.Strm), Win_Bits) /= Thin.Z_OK
364 then
365 Raise_Error (Filter.Strm.all);
366 end if;
367 end Inflate_Init;
368
369 -------------
370 -- Is_Open --
371 -------------
372
373 function Is_Open (Filter : in Filter_Type) return Boolean is
374 begin
375 return Filter.Strm /= null;
376 end Is_Open;
377
378 -----------------
379 -- Raise_Error --
380 -----------------
381
382 procedure Raise_Error (Message : in String) is
383 begin
384 Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message);
385 end Raise_Error;
386
387 procedure Raise_Error (Stream : in Z_Stream) is
388 begin
389 Raise_Error (Last_Error_Message (Stream));
390 end Raise_Error;
391
392 ----------
393 -- Read --
394 ----------
395
396 procedure Read
397 (Filter : in out Filter_Type;
398 Item : out Ada.Streams.Stream_Element_Array;
399 Last : out Ada.Streams.Stream_Element_Offset;
400 Flush : in Flush_Mode := No_Flush)
401 is
402 In_Last : Stream_Element_Offset;
403 Item_First : Ada.Streams.Stream_Element_Offset := Item'First;
404 V_Flush : Flush_Mode := Flush;
405
406 begin
407 pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1);
408 pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last);
409
410 loop
411 if Rest_Last = Buffer'First - 1 then
412 V_Flush := Finish;
413
414 elsif Rest_First > Rest_Last then
415 Read (Buffer, Rest_Last);
416 Rest_First := Buffer'First;
417
418 if Rest_Last < Buffer'First then
419 V_Flush := Finish;
420 end if;
421 end if;
422
423 Translate
424 (Filter => Filter,
425 In_Data => Buffer (Rest_First .. Rest_Last),
426 In_Last => In_Last,
427 Out_Data => Item (Item_First .. Item'Last),
428 Out_Last => Last,
429 Flush => V_Flush);
430
431 Rest_First := In_Last + 1;
432
433 exit when Stream_End (Filter)
434 or else Last = Item'Last
435 or else (Last >= Item'First and then Allow_Read_Some);
436
437 Item_First := Last + 1;
438 end loop;
439 end Read;
440
441 ----------------
442 -- Stream_End --
443 ----------------
444
445 function Stream_End (Filter : in Filter_Type) return Boolean is
446 begin
447 if Filter.Header = GZip and Filter.Compression then
448 return Filter.Stream_End
449 and then Filter.Offset = Footer_Array'Last + 1;
450 else
451 return Filter.Stream_End;
452 end if;
453 end Stream_End;
454
455 --------------
456 -- Total_In --
457 --------------
458
459 function Total_In (Filter : in Filter_Type) return Count is
460 begin
461 return Count (Thin.Total_In (To_Thin_Access (Filter.Strm).all));
462 end Total_In;
463
464 ---------------
465 -- Total_Out --
466 ---------------
467
468 function Total_Out (Filter : in Filter_Type) return Count is
469 begin
470 return Count (Thin.Total_Out (To_Thin_Access (Filter.Strm).all));
471 end Total_Out;
472
473 ---------------
474 -- Translate --
475 ---------------
476
477 procedure Translate
478 (Filter : in out Filter_Type;
479 In_Data : in Ada.Streams.Stream_Element_Array;
480 In_Last : out Ada.Streams.Stream_Element_Offset;
481 Out_Data : out Ada.Streams.Stream_Element_Array;
482 Out_Last : out Ada.Streams.Stream_Element_Offset;
483 Flush : in Flush_Mode) is
484 begin
485 if Filter.Header = GZip and then Filter.Compression then
486 Translate_GZip
487 (Filter => Filter,
488 In_Data => In_Data,
489 In_Last => In_Last,
490 Out_Data => Out_Data,
491 Out_Last => Out_Last,
492 Flush => Flush);
493 else
494 Translate_Auto
495 (Filter => Filter,
496 In_Data => In_Data,
497 In_Last => In_Last,
498 Out_Data => Out_Data,
499 Out_Last => Out_Last,
500 Flush => Flush);
501 end if;
502 end Translate;
503
504 --------------------
505 -- Translate_Auto --
506 --------------------
507
508 procedure Translate_Auto
509 (Filter : in out Filter_Type;
510 In_Data : in Ada.Streams.Stream_Element_Array;
511 In_Last : out Ada.Streams.Stream_Element_Offset;
512 Out_Data : out Ada.Streams.Stream_Element_Array;
513 Out_Last : out Ada.Streams.Stream_Element_Offset;
514 Flush : in Flush_Mode)
515 is
516 use type Thin.Int;
517 Code : Thin.Int;
518
519 begin
520 if not Is_Open (Filter) then
521 raise Status_Error;
522 end if;
523
524 if Out_Data'Length = 0 and then In_Data'Length = 0 then
525 raise Constraint_Error;
526 end if;
527
528 Set_Out (Filter.Strm.all, Out_Data'Address, Out_Data'Length);
529 Set_In (Filter.Strm.all, In_Data'Address, In_Data'Length);
530
531 Code := Flate (Filter.Compression).Step
532 (To_Thin_Access (Filter.Strm),
533 Thin.Int (Flush));
534
535 if Code = Thin.Z_STREAM_END then
536 Filter.Stream_End := True;
537 else
538 Check_Error (Filter.Strm.all, Code);
539 end if;
540
541 In_Last := In_Data'Last
542 - Stream_Element_Offset (Avail_In (Filter.Strm.all));
543 Out_Last := Out_Data'Last
544 - Stream_Element_Offset (Avail_Out (Filter.Strm.all));
545 end Translate_Auto;
546
547 --------------------
548 -- Translate_GZip --
549 --------------------
550
551 procedure Translate_GZip
552 (Filter : in out Filter_Type;
553 In_Data : in Ada.Streams.Stream_Element_Array;
554 In_Last : out Ada.Streams.Stream_Element_Offset;
555 Out_Data : out Ada.Streams.Stream_Element_Array;
556 Out_Last : out Ada.Streams.Stream_Element_Offset;
557 Flush : in Flush_Mode)
558 is
559 Out_First : Stream_Element_Offset;
560
561 procedure Add_Data (Data : in Stream_Element_Array);
562 -- Add data to stream from the Filter.Offset till necessary,
563 -- used for add gzip headr/footer.
564
565 procedure Put_32
566 (Item : in out Stream_Element_Array;
567 Data : in Unsigned_32);
568 pragma Inline (Put_32);
569
570 --------------
571 -- Add_Data --
572 --------------
573
574 procedure Add_Data (Data : in Stream_Element_Array) is
575 Data_First : Stream_Element_Offset renames Filter.Offset;
576 Data_Last : Stream_Element_Offset;
577 Data_Len : Stream_Element_Offset; -- -1
578 Out_Len : Stream_Element_Offset; -- -1
579 begin
580 Out_First := Out_Last + 1;
581
582 if Data_First > Data'Last then
583 return;
584 end if;
585
586 Data_Len := Data'Last - Data_First;
587 Out_Len := Out_Data'Last - Out_First;
588
589 if Data_Len <= Out_Len then
590 Out_Last := Out_First + Data_Len;
591 Data_Last := Data'Last;
592 else
593 Out_Last := Out_Data'Last;
594 Data_Last := Data_First + Out_Len;
595 end if;
596
597 Out_Data (Out_First .. Out_Last) := Data (Data_First .. Data_Last);
598
599 Data_First := Data_Last + 1;
600 Out_First := Out_Last + 1;
601 end Add_Data;
602
603 ------------
604 -- Put_32 --
605 ------------
606
607 procedure Put_32
608 (Item : in out Stream_Element_Array;
609 Data : in Unsigned_32)
610 is
611 D : Unsigned_32 := Data;
612 begin
613 for J in Item'First .. Item'First + 3 loop
614 Item (J) := Stream_Element (D and 16#FF#);
615 D := Shift_Right (D, 8);
616 end loop;
617 end Put_32;
618
619 begin
620 Out_Last := Out_Data'First - 1;
621
622 if not Filter.Stream_End then
623 Add_Data (Simple_GZip_Header);
624
625 Translate_Auto
626 (Filter => Filter,
627 In_Data => In_Data,
628 In_Last => In_Last,
629 Out_Data => Out_Data (Out_First .. Out_Data'Last),
630 Out_Last => Out_Last,
631 Flush => Flush);
632
633 CRC32 (Filter.CRC, In_Data (In_Data'First .. In_Last));
634 end if;
635
636 if Filter.Stream_End and then Out_Last <= Out_Data'Last then
637 -- This detection method would work only when
638 -- Simple_GZip_Header'Last > Footer_Array'Last
639
640 if Filter.Offset = Simple_GZip_Header'Last + 1 then
641 Filter.Offset := Footer_Array'First;
642 end if;
643
644 declare
645 Footer : Footer_Array;
646 begin
647 Put_32 (Footer, Filter.CRC);
648 Put_32 (Footer (Footer'First + 4 .. Footer'Last),
649 Unsigned_32 (Total_In (Filter)));
650 Add_Data (Footer);
651 end;
652 end if;
653 end Translate_GZip;
654
655 -------------
656 -- Version --
657 -------------
658
659 function Version return String is
660 begin
661 return Interfaces.C.Strings.Value (Thin.zlibVersion);
662 end Version;
663
664 -----------
665 -- Write --
666 -----------
667
668 procedure Write
669 (Filter : in out Filter_Type;
670 Item : in Ada.Streams.Stream_Element_Array;
671 Flush : in Flush_Mode := No_Flush)
672 is
673 Buffer : Stream_Element_Array (1 .. Buffer_Size);
674 In_Last : Stream_Element_Offset;
675 Out_Last : Stream_Element_Offset;
676 In_First : Stream_Element_Offset := Item'First;
677 begin
678 if Item'Length = 0 and Flush = No_Flush then
679 return;
680 end if;
681
682 loop
683 Translate
684 (Filter => Filter,
685 In_Data => Item (In_First .. Item'Last),
686 In_Last => In_Last,
687 Out_Data => Buffer,
688 Out_Last => Out_Last,
689 Flush => Flush);
690
691 if Out_Last >= Buffer'First then
692 Write (Buffer (1 .. Out_Last));
693 end if;
694
695 exit when In_Last = Item'Last or Stream_End (Filter);
696
697 In_First := In_Last + 1;
698 end loop;
699 end Write;
700
701 end ZLib;