| ---------------------------------------------------------------- |
| -- ZLib for Ada thick binding. -- |
| -- -- |
| -- Copyright (C) 2002-2004 Dmitriy Anisimkov -- |
| -- -- |
| -- Open source license information is in the zlib.ads file. -- |
| ---------------------------------------------------------------- |
| |
| -- $Id: zlib.adb,v 1.31 2004/09/06 06:53:19 vagul Exp $ |
| |
| with Ada.Exceptions; |
| with Ada.Unchecked_Conversion; |
| with Ada.Unchecked_Deallocation; |
| |
| with Interfaces.C.Strings; |
| |
| with ZLib.Thin; |
| |
| package body ZLib is |
| |
| use type Thin.Int; |
| |
| type Z_Stream is new Thin.Z_Stream; |
| |
| type Return_Code_Enum is |
| (OK, |
| STREAM_END, |
| NEED_DICT, |
| ERRNO, |
| STREAM_ERROR, |
| DATA_ERROR, |
| MEM_ERROR, |
| BUF_ERROR, |
| VERSION_ERROR); |
| |
| type Flate_Step_Function is access |
| function (Strm : in Thin.Z_Streamp; Flush : in Thin.Int) return Thin.Int; |
| pragma Convention (C, Flate_Step_Function); |
| |
| type Flate_End_Function is access |
| function (Ctrm : in Thin.Z_Streamp) return Thin.Int; |
| pragma Convention (C, Flate_End_Function); |
| |
| type Flate_Type is record |
| Step : Flate_Step_Function; |
| Done : Flate_End_Function; |
| end record; |
| |
| subtype Footer_Array is Stream_Element_Array (1 .. 8); |
| |
| Simple_GZip_Header : constant Stream_Element_Array (1 .. 10) |
| := (16#1f#, 16#8b#, -- Magic header |
| 16#08#, -- Z_DEFLATED |
| 16#00#, -- Flags |
| 16#00#, 16#00#, 16#00#, 16#00#, -- Time |
| 16#00#, -- XFlags |
| 16#03# -- OS code |
| ); |
| -- The simplest gzip header is not for informational, but just for |
| -- gzip format compatibility. |
| -- Note that some code below is using assumption |
| -- Simple_GZip_Header'Last > Footer_Array'Last, so do not make |
| -- Simple_GZip_Header'Last <= Footer_Array'Last. |
| |
| Return_Code : constant array (Thin.Int range <>) of Return_Code_Enum |
| := (0 => OK, |
| 1 => STREAM_END, |
| 2 => NEED_DICT, |
| -1 => ERRNO, |
| -2 => STREAM_ERROR, |
| -3 => DATA_ERROR, |
| -4 => MEM_ERROR, |
| -5 => BUF_ERROR, |
| -6 => VERSION_ERROR); |
| |
| Flate : constant array (Boolean) of Flate_Type |
| := (True => (Step => Thin.Deflate'Access, |
| Done => Thin.DeflateEnd'Access), |
| False => (Step => Thin.Inflate'Access, |
| Done => Thin.InflateEnd'Access)); |
| |
| Flush_Finish : constant array (Boolean) of Flush_Mode |
| := (True => Finish, False => No_Flush); |
| |
| procedure Raise_Error (Stream : in Z_Stream); |
| pragma Inline (Raise_Error); |
| |
| procedure Raise_Error (Message : in String); |
| pragma Inline (Raise_Error); |
| |
| procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int); |
| |
| procedure Free is new Ada.Unchecked_Deallocation |
| (Z_Stream, Z_Stream_Access); |
| |
| function To_Thin_Access is new Ada.Unchecked_Conversion |
| (Z_Stream_Access, Thin.Z_Streamp); |
| |
| procedure Translate_GZip |
| (Filter : in out Filter_Type; |
| In_Data : in Ada.Streams.Stream_Element_Array; |
| In_Last : out Ada.Streams.Stream_Element_Offset; |
| Out_Data : out Ada.Streams.Stream_Element_Array; |
| Out_Last : out Ada.Streams.Stream_Element_Offset; |
| Flush : in Flush_Mode); |
| -- Separate translate routine for make gzip header. |
| |
| procedure Translate_Auto |
| (Filter : in out Filter_Type; |
| In_Data : in Ada.Streams.Stream_Element_Array; |
| In_Last : out Ada.Streams.Stream_Element_Offset; |
| Out_Data : out Ada.Streams.Stream_Element_Array; |
| Out_Last : out Ada.Streams.Stream_Element_Offset; |
| Flush : in Flush_Mode); |
| -- translate routine without additional headers. |
| |
| ----------------- |
| -- Check_Error -- |
| ----------------- |
| |
| procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int) is |
| use type Thin.Int; |
| begin |
| if Code /= Thin.Z_OK then |
| Raise_Error |
| (Return_Code_Enum'Image (Return_Code (Code)) |
| & ": " & Last_Error_Message (Stream)); |
| end if; |
| end Check_Error; |
| |
| ----------- |
| -- Close -- |
| ----------- |
| |
| procedure Close |
| (Filter : in out Filter_Type; |
| Ignore_Error : in Boolean := False) |
| is |
| Code : Thin.Int; |
| begin |
| if not Ignore_Error and then not Is_Open (Filter) then |
| raise Status_Error; |
| end if; |
| |
| Code := Flate (Filter.Compression).Done (To_Thin_Access (Filter.Strm)); |
| |
| if Ignore_Error or else Code = Thin.Z_OK then |
| Free (Filter.Strm); |
| else |
| declare |
| Error_Message : constant String |
| := Last_Error_Message (Filter.Strm.all); |
| begin |
| Free (Filter.Strm); |
| Ada.Exceptions.Raise_Exception |
| (ZLib_Error'Identity, |
| Return_Code_Enum'Image (Return_Code (Code)) |
| & ": " & Error_Message); |
| end; |
| end if; |
| end Close; |
| |
| ----------- |
| -- CRC32 -- |
| ----------- |
| |
| function CRC32 |
| (CRC : in Unsigned_32; |
| Data : in Ada.Streams.Stream_Element_Array) |
| return Unsigned_32 |
| is |
| use Thin; |
| begin |
| return Unsigned_32 (crc32 (ULong (CRC), |
| Data'Address, |
| Data'Length)); |
| end CRC32; |
| |
| procedure CRC32 |
| (CRC : in out Unsigned_32; |
| Data : in Ada.Streams.Stream_Element_Array) is |
| begin |
| CRC := CRC32 (CRC, Data); |
| end CRC32; |
| |
| ------------------ |
| -- Deflate_Init -- |
| ------------------ |
| |
| procedure Deflate_Init |
| (Filter : in out Filter_Type; |
| Level : in Compression_Level := Default_Compression; |
| Strategy : in Strategy_Type := Default_Strategy; |
| Method : in Compression_Method := Deflated; |
| Window_Bits : in Window_Bits_Type := Default_Window_Bits; |
| Memory_Level : in Memory_Level_Type := Default_Memory_Level; |
| Header : in Header_Type := Default) |
| is |
| use type Thin.Int; |
| Win_Bits : Thin.Int := Thin.Int (Window_Bits); |
| begin |
| if Is_Open (Filter) then |
| raise Status_Error; |
| end if; |
| |
| -- We allow ZLib to make header only in case of default header type. |
| -- Otherwise we would either do header by ourselves, or do not do |
| -- header at all. |
| |
| if Header = None or else Header = GZip then |
| Win_Bits := -Win_Bits; |
| end if; |
| |
| -- For the GZip CRC calculation and make headers. |
| |
| if Header = GZip then |
| Filter.CRC := 0; |
| Filter.Offset := Simple_GZip_Header'First; |
| else |
| Filter.Offset := Simple_GZip_Header'Last + 1; |
| end if; |
| |
| Filter.Strm := new Z_Stream; |
| Filter.Compression := True; |
| Filter.Stream_End := False; |
| Filter.Header := Header; |
| |
| if Thin.Deflate_Init |
| (To_Thin_Access (Filter.Strm), |
| Level => Thin.Int (Level), |
| method => Thin.Int (Method), |
| windowBits => Win_Bits, |
| memLevel => Thin.Int (Memory_Level), |
| strategy => Thin.Int (Strategy)) /= Thin.Z_OK |
| then |
| Raise_Error (Filter.Strm.all); |
| end if; |
| end Deflate_Init; |
| |
| ----------- |
| -- Flush -- |
| ----------- |
| |
| procedure Flush |
| (Filter : in out Filter_Type; |
| Out_Data : out Ada.Streams.Stream_Element_Array; |
| Out_Last : out Ada.Streams.Stream_Element_Offset; |
| Flush : in Flush_Mode) |
| is |
| No_Data : Stream_Element_Array := (1 .. 0 => 0); |
| Last : Stream_Element_Offset; |
| begin |
| Translate (Filter, No_Data, Last, Out_Data, Out_Last, Flush); |
| end Flush; |
| |
| ----------------------- |
| -- Generic_Translate -- |
| ----------------------- |
| |
| procedure Generic_Translate |
| (Filter : in out ZLib.Filter_Type; |
| In_Buffer_Size : in Integer := Default_Buffer_Size; |
| Out_Buffer_Size : in Integer := Default_Buffer_Size) |
| is |
| In_Buffer : Stream_Element_Array |
| (1 .. Stream_Element_Offset (In_Buffer_Size)); |
| Out_Buffer : Stream_Element_Array |
| (1 .. Stream_Element_Offset (Out_Buffer_Size)); |
| Last : Stream_Element_Offset; |
| In_Last : Stream_Element_Offset; |
| In_First : Stream_Element_Offset; |
| Out_Last : Stream_Element_Offset; |
| begin |
| Main : loop |
| Data_In (In_Buffer, Last); |
| |
| In_First := In_Buffer'First; |
| |
| loop |
| Translate |
| (Filter => Filter, |
| In_Data => In_Buffer (In_First .. Last), |
| In_Last => In_Last, |
| Out_Data => Out_Buffer, |
| Out_Last => Out_Last, |
| Flush => Flush_Finish (Last < In_Buffer'First)); |
| |
| if Out_Buffer'First <= Out_Last then |
| Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last)); |
| end if; |
| |
| exit Main when Stream_End (Filter); |
| |
| -- The end of in buffer. |
| |
| exit when In_Last = Last; |
| |
| In_First := In_Last + 1; |
| end loop; |
| end loop Main; |
| |
| end Generic_Translate; |
| |
| ------------------ |
| -- Inflate_Init -- |
| ------------------ |
| |
| procedure Inflate_Init |
| (Filter : in out Filter_Type; |
| Window_Bits : in Window_Bits_Type := Default_Window_Bits; |
| Header : in Header_Type := Default) |
| is |
| use type Thin.Int; |
| Win_Bits : Thin.Int := Thin.Int (Window_Bits); |
| |
| procedure Check_Version; |
| -- Check the latest header types compatibility. |
| |
| procedure Check_Version is |
| begin |
| if Version <= "1.1.4" then |
| Raise_Error |
| ("Inflate header type " & Header_Type'Image (Header) |
| & " incompatible with ZLib version " & Version); |
| end if; |
| end Check_Version; |
| |
| begin |
| if Is_Open (Filter) then |
| raise Status_Error; |
| end if; |
| |
| case Header is |
| when None => |
| Check_Version; |
| |
| -- Inflate data without headers determined |
| -- by negative Win_Bits. |
| |
| Win_Bits := -Win_Bits; |
| when GZip => |
| Check_Version; |
| |
| -- Inflate gzip data defined by flag 16. |
| |
| Win_Bits := Win_Bits + 16; |
| when Auto => |
| Check_Version; |
| |
| -- Inflate with automatic detection |
| -- of gzip or native header defined by flag 32. |
| |
| Win_Bits := Win_Bits + 32; |
| when Default => null; |
| end case; |
| |
| Filter.Strm := new Z_Stream; |
| Filter.Compression := False; |
| Filter.Stream_End := False; |
| Filter.Header := Header; |
| |
| if Thin.Inflate_Init |
| (To_Thin_Access (Filter.Strm), Win_Bits) /= Thin.Z_OK |
| then |
| Raise_Error (Filter.Strm.all); |
| end if; |
| end Inflate_Init; |
| |
| ------------- |
| -- Is_Open -- |
| ------------- |
| |
| function Is_Open (Filter : in Filter_Type) return Boolean is |
| begin |
| return Filter.Strm /= null; |
| end Is_Open; |
| |
| ----------------- |
| -- Raise_Error -- |
| ----------------- |
| |
| procedure Raise_Error (Message : in String) is |
| begin |
| Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message); |
| end Raise_Error; |
| |
| procedure Raise_Error (Stream : in Z_Stream) is |
| begin |
| Raise_Error (Last_Error_Message (Stream)); |
| end Raise_Error; |
| |
| ---------- |
| -- Read -- |
| ---------- |
| |
| procedure Read |
| (Filter : in out Filter_Type; |
| Item : out Ada.Streams.Stream_Element_Array; |
| Last : out Ada.Streams.Stream_Element_Offset; |
| Flush : in Flush_Mode := No_Flush) |
| is |
| In_Last : Stream_Element_Offset; |
| Item_First : Ada.Streams.Stream_Element_Offset := Item'First; |
| V_Flush : Flush_Mode := Flush; |
| |
| begin |
| pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1); |
| pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last); |
| |
| loop |
| if Rest_Last = Buffer'First - 1 then |
| V_Flush := Finish; |
| |
| elsif Rest_First > Rest_Last then |
| Read (Buffer, Rest_Last); |
| Rest_First := Buffer'First; |
| |
| if Rest_Last < Buffer'First then |
| V_Flush := Finish; |
| end if; |
| end if; |
| |
| Translate |
| (Filter => Filter, |
| In_Data => Buffer (Rest_First .. Rest_Last), |
| In_Last => In_Last, |
| Out_Data => Item (Item_First .. Item'Last), |
| Out_Last => Last, |
| Flush => V_Flush); |
| |
| Rest_First := In_Last + 1; |
| |
| exit when Stream_End (Filter) |
| or else Last = Item'Last |
| or else (Last >= Item'First and then Allow_Read_Some); |
| |
| Item_First := Last + 1; |
| end loop; |
| end Read; |
| |
| ---------------- |
| -- Stream_End -- |
| ---------------- |
| |
| function Stream_End (Filter : in Filter_Type) return Boolean is |
| begin |
| if Filter.Header = GZip and Filter.Compression then |
| return Filter.Stream_End |
| and then Filter.Offset = Footer_Array'Last + 1; |
| else |
| return Filter.Stream_End; |
| end if; |
| end Stream_End; |
| |
| -------------- |
| -- Total_In -- |
| -------------- |
| |
| function Total_In (Filter : in Filter_Type) return Count is |
| begin |
| return Count (Thin.Total_In (To_Thin_Access (Filter.Strm).all)); |
| end Total_In; |
| |
| --------------- |
| -- Total_Out -- |
| --------------- |
| |
| function Total_Out (Filter : in Filter_Type) return Count is |
| begin |
| return Count (Thin.Total_Out (To_Thin_Access (Filter.Strm).all)); |
| end Total_Out; |
| |
| --------------- |
| -- Translate -- |
| --------------- |
| |
| procedure Translate |
| (Filter : in out Filter_Type; |
| In_Data : in Ada.Streams.Stream_Element_Array; |
| In_Last : out Ada.Streams.Stream_Element_Offset; |
| Out_Data : out Ada.Streams.Stream_Element_Array; |
| Out_Last : out Ada.Streams.Stream_Element_Offset; |
| Flush : in Flush_Mode) is |
| begin |
| if Filter.Header = GZip and then Filter.Compression then |
| Translate_GZip |
| (Filter => Filter, |
| In_Data => In_Data, |
| In_Last => In_Last, |
| Out_Data => Out_Data, |
| Out_Last => Out_Last, |
| Flush => Flush); |
| else |
| Translate_Auto |
| (Filter => Filter, |
| In_Data => In_Data, |
| In_Last => In_Last, |
| Out_Data => Out_Data, |
| Out_Last => Out_Last, |
| Flush => Flush); |
| end if; |
| end Translate; |
| |
| -------------------- |
| -- Translate_Auto -- |
| -------------------- |
| |
| procedure Translate_Auto |
| (Filter : in out Filter_Type; |
| In_Data : in Ada.Streams.Stream_Element_Array; |
| In_Last : out Ada.Streams.Stream_Element_Offset; |
| Out_Data : out Ada.Streams.Stream_Element_Array; |
| Out_Last : out Ada.Streams.Stream_Element_Offset; |
| Flush : in Flush_Mode) |
| is |
| use type Thin.Int; |
| Code : Thin.Int; |
| |
| begin |
| if not Is_Open (Filter) then |
| raise Status_Error; |
| end if; |
| |
| if Out_Data'Length = 0 and then In_Data'Length = 0 then |
| raise Constraint_Error; |
| end if; |
| |
| Set_Out (Filter.Strm.all, Out_Data'Address, Out_Data'Length); |
| Set_In (Filter.Strm.all, In_Data'Address, In_Data'Length); |
| |
| Code := Flate (Filter.Compression).Step |
| (To_Thin_Access (Filter.Strm), |
| Thin.Int (Flush)); |
| |
| if Code = Thin.Z_STREAM_END then |
| Filter.Stream_End := True; |
| else |
| Check_Error (Filter.Strm.all, Code); |
| end if; |
| |
| In_Last := In_Data'Last |
| - Stream_Element_Offset (Avail_In (Filter.Strm.all)); |
| Out_Last := Out_Data'Last |
| - Stream_Element_Offset (Avail_Out (Filter.Strm.all)); |
| end Translate_Auto; |
| |
| -------------------- |
| -- Translate_GZip -- |
| -------------------- |
| |
| procedure Translate_GZip |
| (Filter : in out Filter_Type; |
| In_Data : in Ada.Streams.Stream_Element_Array; |
| In_Last : out Ada.Streams.Stream_Element_Offset; |
| Out_Data : out Ada.Streams.Stream_Element_Array; |
| Out_Last : out Ada.Streams.Stream_Element_Offset; |
| Flush : in Flush_Mode) |
| is |
| Out_First : Stream_Element_Offset; |
| |
| procedure Add_Data (Data : in Stream_Element_Array); |
| -- Add data to stream from the Filter.Offset till necessary, |
| -- used for add gzip headr/footer. |
| |
| procedure Put_32 |
| (Item : in out Stream_Element_Array; |
| Data : in Unsigned_32); |
| pragma Inline (Put_32); |
| |
| -------------- |
| -- Add_Data -- |
| -------------- |
| |
| procedure Add_Data (Data : in Stream_Element_Array) is |
| Data_First : Stream_Element_Offset renames Filter.Offset; |
| Data_Last : Stream_Element_Offset; |
| Data_Len : Stream_Element_Offset; -- -1 |
| Out_Len : Stream_Element_Offset; -- -1 |
| begin |
| Out_First := Out_Last + 1; |
| |
| if Data_First > Data'Last then |
| return; |
| end if; |
| |
| Data_Len := Data'Last - Data_First; |
| Out_Len := Out_Data'Last - Out_First; |
| |
| if Data_Len <= Out_Len then |
| Out_Last := Out_First + Data_Len; |
| Data_Last := Data'Last; |
| else |
| Out_Last := Out_Data'Last; |
| Data_Last := Data_First + Out_Len; |
| end if; |
| |
| Out_Data (Out_First .. Out_Last) := Data (Data_First .. Data_Last); |
| |
| Data_First := Data_Last + 1; |
| Out_First := Out_Last + 1; |
| end Add_Data; |
| |
| ------------ |
| -- Put_32 -- |
| ------------ |
| |
| procedure Put_32 |
| (Item : in out Stream_Element_Array; |
| Data : in Unsigned_32) |
| is |
| D : Unsigned_32 := Data; |
| begin |
| for J in Item'First .. Item'First + 3 loop |
| Item (J) := Stream_Element (D and 16#FF#); |
| D := Shift_Right (D, 8); |
| end loop; |
| end Put_32; |
| |
| begin |
| Out_Last := Out_Data'First - 1; |
| |
| if not Filter.Stream_End then |
| Add_Data (Simple_GZip_Header); |
| |
| Translate_Auto |
| (Filter => Filter, |
| In_Data => In_Data, |
| In_Last => In_Last, |
| Out_Data => Out_Data (Out_First .. Out_Data'Last), |
| Out_Last => Out_Last, |
| Flush => Flush); |
| |
| CRC32 (Filter.CRC, In_Data (In_Data'First .. In_Last)); |
| end if; |
| |
| if Filter.Stream_End and then Out_Last <= Out_Data'Last then |
| -- This detection method would work only when |
| -- Simple_GZip_Header'Last > Footer_Array'Last |
| |
| if Filter.Offset = Simple_GZip_Header'Last + 1 then |
| Filter.Offset := Footer_Array'First; |
| end if; |
| |
| declare |
| Footer : Footer_Array; |
| begin |
| Put_32 (Footer, Filter.CRC); |
| Put_32 (Footer (Footer'First + 4 .. Footer'Last), |
| Unsigned_32 (Total_In (Filter))); |
| Add_Data (Footer); |
| end; |
| end if; |
| end Translate_GZip; |
| |
| ------------- |
| -- Version -- |
| ------------- |
| |
| function Version return String is |
| begin |
| return Interfaces.C.Strings.Value (Thin.zlibVersion); |
| end Version; |
| |
| ----------- |
| -- Write -- |
| ----------- |
| |
| procedure Write |
| (Filter : in out Filter_Type; |
| Item : in Ada.Streams.Stream_Element_Array; |
| Flush : in Flush_Mode := No_Flush) |
| is |
| Buffer : Stream_Element_Array (1 .. Buffer_Size); |
| In_Last : Stream_Element_Offset; |
| Out_Last : Stream_Element_Offset; |
| In_First : Stream_Element_Offset := Item'First; |
| begin |
| if Item'Length = 0 and Flush = No_Flush then |
| return; |
| end if; |
| |
| loop |
| Translate |
| (Filter => Filter, |
| In_Data => Item (In_First .. Item'Last), |
| In_Last => In_Last, |
| Out_Data => Buffer, |
| Out_Last => Out_Last, |
| Flush => Flush); |
| |
| if Out_Last >= Buffer'First then |
| Write (Buffer (1 .. Out_Last)); |
| end if; |
| |
| exit when In_Last = Item'Last or Stream_End (Filter); |
| |
| In_First := In_Last + 1; |
| end loop; |
| end Write; |
| |
| end ZLib; |
