+++ /dev/null
-----------------------------------------------------------------
--- 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 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;
git.samba.org / samba.git / blobdiff