File : zlib.adb


----------------------------------------------------------------

--  ZLib for Ada thick binding.                               --

--                                                            --

--  Copyright (C) 2002-2003 Dmitriy Anisimkov                 --

--                                                            --

--  Open source license information is in the zlib.ads file.  --

----------------------------------------------------------------


--  $Id: zlib.adb,v 1.3 2003/10/11 11:36:37 Jano 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 : Thin.Z_Streamp; flush : 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;

   type Translate_Procedure is access procedure
     (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);

   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.


   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 : Z_Stream);
   pragma Inline (Raise_Error);

   procedure Raise_Error (Message : String);
   pragma Inline (Raise_Error);

   procedure Check_Error (Stream : Z_Stream; Code : Thin.Int);

   procedure Check_Error (Code : 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.


   Translate_Routine : constant array (Header_Type) of Translate_Procedure
     := (None => Translate_Auto'Access,
         Auto => Translate_Auto'Access,
         GZip => Translate_GZip'Access);

   -----------------

   -- Check_Error --

   -----------------


   procedure Check_Error (Code : Thin.Int) is
      use type Thin.Int;
   begin
      if Code /= Thin.Z_OK then
         Raise_Error
           ("Error code " & Return_Code_Enum'Image (Return_Code (Code)));
      end if;
   end Check_Error;

   -----------------

   -- Check_Error --

   -----------------


   procedure Check_Error (Stream : Z_Stream; Code : 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) is
      Code : Thin.Int;
   begin
      Code := Flate (Filter.Compression).Done
          (To_Thin_Access (Filter.Strm));
      Filter.Opened := False;
      if Code = Thin.Z_OK then
         Free (Filter.Strm);
      elsif Filter.Strm /= null then
         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),
         Bytes.To_Pointer (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   := 15;
      Memory_Level : in     Memory_Level_Type  := 8;
      Header       : in     Header_Type        := Auto)
   is
      use type Thin.Int;
      Win_Bits : Thin.Int := Thin.Int (Window_Bits);
   begin
      --  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 /= Auto 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.Opened      := True;
      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  : Integer := Default_Buffer_Size;
      Out_Buffer_Size : 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,
               In_Buffer (In_First .. Last),
               In_Last,
               Out_Buffer,
               Out_Last,
               Flush_Finish (Last < In_Buffer'First));

            Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last));

            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 := 15;
      Header      : in     Header_Type      := Auto)
   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 incompatible with ZLib version "
                & Version);
         end if;
      end Check_Version;

   begin
      case Header is
         when None =>
            Check_Version;

            --  if deflated data without header, we should warn decompressor

            --  about it, otherwise it would try to detect header.


            Win_Bits := -Win_Bits;
         when GZip =>
            Check_Version;
         when Auto => null;
      end case;

      Filter.Strm := new Z_Stream;
      Filter.Compression := False;
      Filter.Stream_End  := False;
      Filter.Opened      := True;
      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;

   -----------------

   -- Raise_Error --

   -----------------


   procedure Raise_Error (Message : String) is
   begin
      Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message);
   end Raise_Error;

   procedure Raise_Error (Stream : 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)
   is
      In_Last    : Stream_Element_Offset;
      Item_First : Ada.Streams.Stream_Element_Offset := Item'First;

   begin
      pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1);

      loop
         if Rest_First > Buffer'Last then
            Read (Buffer, Rest_Last);
            Rest_First := Buffer'First;
         end if;

         pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last);

         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    => Flush_Finish (Rest_Last < Rest_First));

         Rest_First := In_Last + 1;

         exit when Last = Item'Last or else Stream_End (Filter);

         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 Filter.Opened = False then
         raise ZLib_Error;
      end if;

      if Out_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)
   is
      Buffer : Stream_Element_Array (1 .. Buffer_Size);
      In_Last, 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;

begin
   if Simple_GZip_Header'Last <= Footer_Array'Last then
      raise Program_Error;
   end if;
end ZLib;