----------------------------------------------------------------
-- 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 2023/03/21 16:41:53 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;