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

-- 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;