1 ----------------------------------------------------------------
2 -- ZLib for Ada thick binding. --
4 -- Copyright (C) 2002-2004 Dmitriy Anisimkov --
6 -- Open source license information is in the zlib.ads file. --
7 ----------------------------------------------------------------
9 -- $Id: zlib.adb,v 1.31 2004/09/06 06:53:19 vagul Exp $
12 with Ada.Unchecked_Conversion;
13 with Ada.Unchecked_Deallocation;
15 with Interfaces.C.Strings;
23 type Z_Stream is new Thin.Z_Stream;
25 type Return_Code_Enum is
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);
40 type Flate_End_Function is access
41 function (Ctrm : in Thin.Z_Streamp) return Thin.Int;
42 pragma Convention (C, Flate_End_Function);
44 type Flate_Type is record
45 Step : Flate_Step_Function;
46 Done : Flate_End_Function;
49 subtype Footer_Array is Stream_Element_Array (1 .. 8);
51 Simple_GZip_Header : constant Stream_Element_Array (1 .. 10)
52 := (16#1f#, 16#8b#, -- Magic header
55 16#00#, 16#00#, 16#00#, 16#00#, -- Time
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.
65 Return_Code : constant array (Thin.Int range <>) of Return_Code_Enum
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));
82 Flush_Finish : constant array (Boolean) of Flush_Mode
83 := (True => Finish, False => No_Flush);
85 procedure Raise_Error (Stream : in Z_Stream);
86 pragma Inline (Raise_Error);
88 procedure Raise_Error (Message : in String);
89 pragma Inline (Raise_Error);
91 procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int);
93 procedure Free is new Ada.Unchecked_Deallocation
94 (Z_Stream, Z_Stream_Access);
96 function To_Thin_Access is new Ada.Unchecked_Conversion
97 (Z_Stream_Access, Thin.Z_Streamp);
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.
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.
121 procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int) is
124 if Code /= Thin.Z_OK then
126 (Return_Code_Enum'Image (Return_Code (Code))
127 & ": " & Last_Error_Message (Stream));
136 (Filter : in out Filter_Type;
137 Ignore_Error : in Boolean := False)
141 if not Ignore_Error and then not Is_Open (Filter) then
145 Code := Flate (Filter.Compression).Done (To_Thin_Access (Filter.Strm));
147 if Ignore_Error or else Code = Thin.Z_OK then
151 Error_Message : constant String
152 := Last_Error_Message (Filter.Strm.all);
155 Ada.Exceptions.Raise_Exception
156 (ZLib_Error'Identity,
157 Return_Code_Enum'Image (Return_Code (Code))
158 & ": " & Error_Message);
168 (CRC : in Unsigned_32;
169 Data : in Ada.Streams.Stream_Element_Array)
174 return Unsigned_32 (crc32 (ULong (CRC),
180 (CRC : in out Unsigned_32;
181 Data : in Ada.Streams.Stream_Element_Array) is
183 CRC := CRC32 (CRC, Data);
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)
200 Win_Bits : Thin.Int := Thin.Int (Window_Bits);
202 if Is_Open (Filter) then
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
210 if Header = None or else Header = GZip then
211 Win_Bits := -Win_Bits;
214 -- For the GZip CRC calculation and make headers.
216 if Header = GZip then
218 Filter.Offset := Simple_GZip_Header'First;
220 Filter.Offset := Simple_GZip_Header'Last + 1;
223 Filter.Strm := new Z_Stream;
224 Filter.Compression := True;
225 Filter.Stream_End := False;
226 Filter.Header := Header;
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
236 Raise_Error (Filter.Strm.all);
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)
250 No_Data : Stream_Element_Array := (1 .. 0 => 0);
251 Last : Stream_Element_Offset;
253 Translate (Filter, No_Data, Last, Out_Data, Out_Last, Flush);
256 -----------------------
257 -- Generic_Translate --
258 -----------------------
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)
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;
275 Data_In (In_Buffer, Last);
277 In_First := In_Buffer'First;
282 In_Data => In_Buffer (In_First .. Last),
284 Out_Data => Out_Buffer,
285 Out_Last => Out_Last,
286 Flush => Flush_Finish (Last < In_Buffer'First));
288 if Out_Buffer'First <= Out_Last then
289 Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last));
292 exit Main when Stream_End (Filter);
294 -- The end of in buffer.
296 exit when In_Last = Last;
298 In_First := In_Last + 1;
302 end Generic_Translate;
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)
314 Win_Bits : Thin.Int := Thin.Int (Window_Bits);
316 procedure Check_Version;
317 -- Check the latest header types compatibility.
319 procedure Check_Version is
321 if Version <= "1.1.4" then
323 ("Inflate header type " & Header_Type'Image (Header)
324 & " incompatible with ZLib version " & Version);
329 if Is_Open (Filter) then
337 -- Inflate data without headers determined
338 -- by negative Win_Bits.
340 Win_Bits := -Win_Bits;
344 -- Inflate gzip data defined by flag 16.
346 Win_Bits := Win_Bits + 16;
350 -- Inflate with automatic detection
351 -- of gzip or native header defined by flag 32.
353 Win_Bits := Win_Bits + 32;
354 when Default => null;
357 Filter.Strm := new Z_Stream;
358 Filter.Compression := False;
359 Filter.Stream_End := False;
360 Filter.Header := Header;
363 (To_Thin_Access (Filter.Strm), Win_Bits) /= Thin.Z_OK
365 Raise_Error (Filter.Strm.all);
373 function Is_Open (Filter : in Filter_Type) return Boolean is
375 return Filter.Strm /= null;
382 procedure Raise_Error (Message : in String) is
384 Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message);
387 procedure Raise_Error (Stream : in Z_Stream) is
389 Raise_Error (Last_Error_Message (Stream));
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)
402 In_Last : Stream_Element_Offset;
403 Item_First : Ada.Streams.Stream_Element_Offset := Item'First;
404 V_Flush : Flush_Mode := Flush;
407 pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1);
408 pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last);
411 if Rest_Last = Buffer'First - 1 then
414 elsif Rest_First > Rest_Last then
415 Read (Buffer, Rest_Last);
416 Rest_First := Buffer'First;
418 if Rest_Last < Buffer'First then
425 In_Data => Buffer (Rest_First .. Rest_Last),
427 Out_Data => Item (Item_First .. Item'Last),
431 Rest_First := In_Last + 1;
433 exit when Stream_End (Filter)
434 or else Last = Item'Last
435 or else (Last >= Item'First and then Allow_Read_Some);
437 Item_First := Last + 1;
445 function Stream_End (Filter : in Filter_Type) return Boolean is
447 if Filter.Header = GZip and Filter.Compression then
448 return Filter.Stream_End
449 and then Filter.Offset = Footer_Array'Last + 1;
451 return Filter.Stream_End;
459 function Total_In (Filter : in Filter_Type) return Count is
461 return Count (Thin.Total_In (To_Thin_Access (Filter.Strm).all));
468 function Total_Out (Filter : in Filter_Type) return Count is
470 return Count (Thin.Total_Out (To_Thin_Access (Filter.Strm).all));
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
485 if Filter.Header = GZip and then Filter.Compression then
490 Out_Data => Out_Data,
491 Out_Last => Out_Last,
498 Out_Data => Out_Data,
499 Out_Last => Out_Last,
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)
520 if not Is_Open (Filter) then
524 if Out_Data'Length = 0 and then In_Data'Length = 0 then
525 raise Constraint_Error;
528 Set_Out (Filter.Strm.all, Out_Data'Address, Out_Data'Length);
529 Set_In (Filter.Strm.all, In_Data'Address, In_Data'Length);
531 Code := Flate (Filter.Compression).Step
532 (To_Thin_Access (Filter.Strm),
535 if Code = Thin.Z_STREAM_END then
536 Filter.Stream_End := True;
538 Check_Error (Filter.Strm.all, Code);
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));
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)
559 Out_First : Stream_Element_Offset;
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.
566 (Item : in out Stream_Element_Array;
567 Data : in Unsigned_32);
568 pragma Inline (Put_32);
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
580 Out_First := Out_Last + 1;
582 if Data_First > Data'Last then
586 Data_Len := Data'Last - Data_First;
587 Out_Len := Out_Data'Last - Out_First;
589 if Data_Len <= Out_Len then
590 Out_Last := Out_First + Data_Len;
591 Data_Last := Data'Last;
593 Out_Last := Out_Data'Last;
594 Data_Last := Data_First + Out_Len;
597 Out_Data (Out_First .. Out_Last) := Data (Data_First .. Data_Last);
599 Data_First := Data_Last + 1;
600 Out_First := Out_Last + 1;
608 (Item : in out Stream_Element_Array;
609 Data : in Unsigned_32)
611 D : Unsigned_32 := Data;
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);
620 Out_Last := Out_Data'First - 1;
622 if not Filter.Stream_End then
623 Add_Data (Simple_GZip_Header);
629 Out_Data => Out_Data (Out_First .. Out_Data'Last),
630 Out_Last => Out_Last,
633 CRC32 (Filter.CRC, In_Data (In_Data'First .. In_Last));
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
640 if Filter.Offset = Simple_GZip_Header'Last + 1 then
641 Filter.Offset := Footer_Array'First;
645 Footer : Footer_Array;
647 Put_32 (Footer, Filter.CRC);
648 Put_32 (Footer (Footer'First + 4 .. Footer'Last),
649 Unsigned_32 (Total_In (Filter)));
659 function Version return String is
661 return Interfaces.C.Strings.Value (Thin.zlibVersion);
669 (Filter : in out Filter_Type;
670 Item : in Ada.Streams.Stream_Element_Array;
671 Flush : in Flush_Mode := No_Flush)
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;
678 if Item'Length = 0 and Flush = No_Flush then
685 In_Data => Item (In_First .. Item'Last),
688 Out_Last => Out_Last,
691 if Out_Last >= Buffer'First then
692 Write (Buffer (1 .. Out_Last));
695 exit when In_Last = Item'Last or Stream_End (Filter);
697 In_First := In_Last + 1;