---------------------------------------------------------------- -- 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.1.1.2 2016/07/28 12:20:05 christos 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 ourselfs, 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;