diff options
Diffstat (limited to 'compat/zlib/contrib/ada')
| -rw-r--r-- | compat/zlib/contrib/ada/buffer_demo.adb | 106 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/mtest.adb | 156 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/read.adb | 156 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/readme.txt | 65 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/test.adb | 463 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/zlib-streams.adb | 225 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/zlib-streams.ads | 114 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/zlib-thin.adb | 141 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/zlib-thin.ads | 450 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/zlib.adb | 701 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/zlib.ads | 328 | ||||
| -rw-r--r-- | compat/zlib/contrib/ada/zlib.gpr | 20 |
12 files changed, 2925 insertions, 0 deletions
diff --git a/compat/zlib/contrib/ada/buffer_demo.adb b/compat/zlib/contrib/ada/buffer_demo.adb new file mode 100644 index 0000000..3926e6f --- /dev/null +++ b/compat/zlib/contrib/ada/buffer_demo.adb @@ -0,0 +1,106 @@ +---------------------------------------------------------------- +-- ZLib for Ada thick binding. -- +-- -- +-- Copyright (C) 2002-2004 Dmitriy Anisimkov -- +-- -- +-- Open source license information is in the zlib.ads file. -- +---------------------------------------------------------------- +-- +-- $Id: buffer_demo.adb,v 1.1 2008/12/19 14:44:49 dkf Exp $ + +-- This demo program provided by Dr Steve Sangwine <sjs@essex.ac.uk> +-- +-- Demonstration of a problem with Zlib-Ada (already fixed) when a buffer +-- of exactly the correct size is used for decompressed data, and the last +-- few bytes passed in to Zlib are checksum bytes. + +-- This program compresses a string of text, and then decompresses the +-- compressed text into a buffer of the same size as the original text. + +with Ada.Streams; use Ada.Streams; +with Ada.Text_IO; + +with ZLib; use ZLib; + +procedure Buffer_Demo is + EOL : Character renames ASCII.LF; + Text : constant String + := "Four score and seven years ago our fathers brought forth," & EOL & + "upon this continent, a new nation, conceived in liberty," & EOL & + "and dedicated to the proposition that `all men are created equal'."; + + Source : Stream_Element_Array (1 .. Text'Length); + for Source'Address use Text'Address; + +begin + Ada.Text_IO.Put (Text); + Ada.Text_IO.New_Line; + Ada.Text_IO.Put_Line + ("Uncompressed size : " & Positive'Image (Text'Length) & " bytes"); + + declare + Compressed_Data : Stream_Element_Array (1 .. Text'Length); + L : Stream_Element_Offset; + begin + Compress : declare + Compressor : Filter_Type; + I : Stream_Element_Offset; + begin + Deflate_Init (Compressor); + + -- Compress the whole of T at once. + + Translate (Compressor, Source, I, Compressed_Data, L, Finish); + pragma Assert (I = Source'Last); + + Close (Compressor); + + Ada.Text_IO.Put_Line + ("Compressed size : " + & Stream_Element_Offset'Image (L) & " bytes"); + end Compress; + + -- Now we decompress the data, passing short blocks of data to Zlib + -- (because this demonstrates the problem - the last block passed will + -- contain checksum information and there will be no output, only a + -- check inside Zlib that the checksum is correct). + + Decompress : declare + Decompressor : Filter_Type; + + Uncompressed_Data : Stream_Element_Array (1 .. Text'Length); + + Block_Size : constant := 4; + -- This makes sure that the last block contains + -- only Adler checksum data. + + P : Stream_Element_Offset := Compressed_Data'First - 1; + O : Stream_Element_Offset; + begin + Inflate_Init (Decompressor); + + loop + Translate + (Decompressor, + Compressed_Data + (P + 1 .. Stream_Element_Offset'Min (P + Block_Size, L)), + P, + Uncompressed_Data + (Total_Out (Decompressor) + 1 .. Uncompressed_Data'Last), + O, + No_Flush); + + Ada.Text_IO.Put_Line + ("Total in : " & Count'Image (Total_In (Decompressor)) & + ", out : " & Count'Image (Total_Out (Decompressor))); + + exit when P = L; + end loop; + + Ada.Text_IO.New_Line; + Ada.Text_IO.Put_Line + ("Decompressed text matches original text : " + & Boolean'Image (Uncompressed_Data = Source)); + end Decompress; + end; +end Buffer_Demo; diff --git a/compat/zlib/contrib/ada/mtest.adb b/compat/zlib/contrib/ada/mtest.adb new file mode 100644 index 0000000..9caaf22 --- /dev/null +++ b/compat/zlib/contrib/ada/mtest.adb @@ -0,0 +1,156 @@ +---------------------------------------------------------------- +-- ZLib for Ada thick binding. -- +-- -- +-- Copyright (C) 2002-2003 Dmitriy Anisimkov -- +-- -- +-- Open source license information is in the zlib.ads file. -- +---------------------------------------------------------------- +-- Continuous test for ZLib multithreading. If the test would fail +-- we should provide thread safe allocation routines for the Z_Stream. +-- +-- $Id: mtest.adb,v 1.1 2008/12/19 14:44:49 dkf Exp $ + +with ZLib; +with Ada.Streams; +with Ada.Numerics.Discrete_Random; +with Ada.Text_IO; +with Ada.Exceptions; +with Ada.Task_Identification; + +procedure MTest is + use Ada.Streams; + use ZLib; + + Stop : Boolean := False; + + pragma Atomic (Stop); + + subtype Visible_Symbols is Stream_Element range 16#20# .. 16#7E#; + + package Random_Elements is + new Ada.Numerics.Discrete_Random (Visible_Symbols); + + task type Test_Task; + + task body Test_Task is + Buffer : Stream_Element_Array (1 .. 100_000); + Gen : Random_Elements.Generator; + + Buffer_First : Stream_Element_Offset; + Compare_First : Stream_Element_Offset; + + Deflate : Filter_Type; + Inflate : Filter_Type; + + procedure Further (Item : in Stream_Element_Array); + + procedure Read_Buffer + (Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + ------------- + -- Further -- + ------------- + + procedure Further (Item : in Stream_Element_Array) is + + procedure Compare (Item : in Stream_Element_Array); + + ------------- + -- Compare -- + ------------- + + procedure Compare (Item : in Stream_Element_Array) is + Next_First : Stream_Element_Offset := Compare_First + Item'Length; + begin + if Buffer (Compare_First .. Next_First - 1) /= Item then + raise Program_Error; + end if; + + Compare_First := Next_First; + end Compare; + + procedure Compare_Write is new ZLib.Write (Write => Compare); + begin + Compare_Write (Inflate, Item, No_Flush); + end Further; + + ----------------- + -- Read_Buffer -- + ----------------- + + procedure Read_Buffer + (Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + Buff_Diff : Stream_Element_Offset := Buffer'Last - Buffer_First; + Next_First : Stream_Element_Offset; + begin + if Item'Length <= Buff_Diff then + Last := Item'Last; + + Next_First := Buffer_First + Item'Length; + + Item := Buffer (Buffer_First .. Next_First - 1); + + Buffer_First := Next_First; + else + Last := Item'First + Buff_Diff; + Item (Item'First .. Last) := Buffer (Buffer_First .. Buffer'Last); + Buffer_First := Buffer'Last + 1; + end if; + end Read_Buffer; + + procedure Translate is new Generic_Translate + (Data_In => Read_Buffer, + Data_Out => Further); + + begin + Random_Elements.Reset (Gen); + + Buffer := (others => 20); + + Main : loop + for J in Buffer'Range loop + Buffer (J) := Random_Elements.Random (Gen); + + Deflate_Init (Deflate); + Inflate_Init (Inflate); + + Buffer_First := Buffer'First; + Compare_First := Buffer'First; + + Translate (Deflate); + + if Compare_First /= Buffer'Last + 1 then + raise Program_Error; + end if; + + Ada.Text_IO.Put_Line + (Ada.Task_Identification.Image + (Ada.Task_Identification.Current_Task) + & Stream_Element_Offset'Image (J) + & ZLib.Count'Image (Total_Out (Deflate))); + + Close (Deflate); + Close (Inflate); + + exit Main when Stop; + end loop; + end loop Main; + exception + when E : others => + Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E)); + Stop := True; + end Test_Task; + + Test : array (1 .. 4) of Test_Task; + + pragma Unreferenced (Test); + + Dummy : Character; + +begin + Ada.Text_IO.Get_Immediate (Dummy); + Stop := True; +end MTest; diff --git a/compat/zlib/contrib/ada/read.adb b/compat/zlib/contrib/ada/read.adb new file mode 100644 index 0000000..365d600 --- /dev/null +++ b/compat/zlib/contrib/ada/read.adb @@ -0,0 +1,156 @@ +---------------------------------------------------------------- +-- ZLib for Ada thick binding. -- +-- -- +-- Copyright (C) 2002-2003 Dmitriy Anisimkov -- +-- -- +-- Open source license information is in the zlib.ads file. -- +---------------------------------------------------------------- + +-- $Id: read.adb,v 1.1 2008/12/19 14:44:49 dkf Exp $ + +-- Test/demo program for the generic read interface. + +with Ada.Numerics.Discrete_Random; +with Ada.Streams; +with Ada.Text_IO; + +with ZLib; + +procedure Read is + + use Ada.Streams; + + ------------------------------------ + -- Test configuration parameters -- + ------------------------------------ + + File_Size : Stream_Element_Offset := 100_000; + + Continuous : constant Boolean := False; + -- If this constant is True, the test would be repeated again and again, + -- with increment File_Size for every iteration. + + Header : constant ZLib.Header_Type := ZLib.Default; + -- Do not use Header other than Default in ZLib versions 1.1.4 and older. + + Init_Random : constant := 8; + -- We are using the same random sequence, in case of we catch bug, + -- so we would be able to reproduce it. + + -- End -- + + Pack_Size : Stream_Element_Offset; + Offset : Stream_Element_Offset; + + Filter : ZLib.Filter_Type; + + subtype Visible_Symbols + is Stream_Element range 16#20# .. 16#7E#; + + package Random_Elements is new + Ada.Numerics.Discrete_Random (Visible_Symbols); + + Gen : Random_Elements.Generator; + Period : constant Stream_Element_Offset := 200; + -- Period constant variable for random generator not to be very random. + -- Bigger period, harder random. + + Read_Buffer : Stream_Element_Array (1 .. 2048); + Read_First : Stream_Element_Offset; + Read_Last : Stream_Element_Offset; + + procedure Reset; + + procedure Read + (Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + -- this procedure is for generic instantiation of + -- ZLib.Read + -- reading data from the File_In. + + procedure Read is new ZLib.Read + (Read, + Read_Buffer, + Rest_First => Read_First, + Rest_Last => Read_Last); + + ---------- + -- Read -- + ---------- + + procedure Read + (Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + begin + Last := Stream_Element_Offset'Min + (Item'Last, + Item'First + File_Size - Offset); + + for J in Item'First .. Last loop + if J < Item'First + Period then + Item (J) := Random_Elements.Random (Gen); + else + Item (J) := Item (J - Period); + end if; + + Offset := Offset + 1; + end loop; + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + begin + Random_Elements.Reset (Gen, Init_Random); + Pack_Size := 0; + Offset := 1; + Read_First := Read_Buffer'Last + 1; + Read_Last := Read_Buffer'Last; + end Reset; + +begin + Ada.Text_IO.Put_Line ("ZLib " & ZLib.Version); + + loop + for Level in ZLib.Compression_Level'Range loop + + Ada.Text_IO.Put ("Level =" + & ZLib.Compression_Level'Image (Level)); + + -- Deflate using generic instantiation. + + ZLib.Deflate_Init + (Filter, + Level, + Header => Header); + + Reset; + + Ada.Text_IO.Put + (Stream_Element_Offset'Image (File_Size) & " ->"); + + loop + declare + Buffer : Stream_Element_Array (1 .. 1024); + Last : Stream_Element_Offset; + begin + Read (Filter, Buffer, Last); + + Pack_Size := Pack_Size + Last - Buffer'First + 1; + + exit when Last < Buffer'Last; + end; + end loop; + + Ada.Text_IO.Put_Line (Stream_Element_Offset'Image (Pack_Size)); + + ZLib.Close (Filter); + end loop; + + exit when not Continuous; + + File_Size := File_Size + 1; + end loop; +end Read; diff --git a/compat/zlib/contrib/ada/readme.txt b/compat/zlib/contrib/ada/readme.txt new file mode 100644 index 0000000..ce4d2ca --- /dev/null +++ b/compat/zlib/contrib/ada/readme.txt @@ -0,0 +1,65 @@ + ZLib for Ada thick binding (ZLib.Ada) + Release 1.3 + +ZLib.Ada is a thick binding interface to the popular ZLib data +compression library, available at http://www.gzip.org/zlib/. +It provides Ada-style access to the ZLib C library. + + + Here are the main changes since ZLib.Ada 1.2: + +- Attension: ZLib.Read generic routine have a initialization requirement + for Read_Last parameter now. It is a bit incompartible with previous version, + but extends functionality, we could use new parameters Allow_Read_Some and + Flush now. + +- Added Is_Open routines to ZLib and ZLib.Streams packages. + +- Add pragma Assert to check Stream_Element is 8 bit. + +- Fix extraction to buffer with exact known decompressed size. Error reported by + Steve Sangwine. + +- Fix definition of ULong (changed to unsigned_long), fix regression on 64 bits + computers. Patch provided by Pascal Obry. + +- Add Status_Error exception definition. + +- Add pragma Assertion that Ada.Streams.Stream_Element size is 8 bit. + + + How to build ZLib.Ada under GNAT + +You should have the ZLib library already build on your computer, before +building ZLib.Ada. Make the directory of ZLib.Ada sources current and +issue the command: + + gnatmake test -largs -L<directory where libz.a is> -lz + +Or use the GNAT project file build for GNAT 3.15 or later: + + gnatmake -Pzlib.gpr -L<directory where libz.a is> + + + How to build ZLib.Ada under Aonix ObjectAda for Win32 7.2.2 + +1. Make a project with all *.ads and *.adb files from the distribution. +2. Build the libz.a library from the ZLib C sources. +3. Rename libz.a to z.lib. +4. Add the library z.lib to the project. +5. Add the libc.lib library from the ObjectAda distribution to the project. +6. Build the executable using test.adb as a main procedure. + + + How to use ZLib.Ada + +The source files test.adb and read.adb are small demo programs that show +the main functionality of ZLib.Ada. + +The routines from the package specifications are commented. + + +Homepage: http://zlib-ada.sourceforge.net/ +Author: Dmitriy Anisimkov <anisimkov@yahoo.com> + +Contributors: Pascal Obry <pascal@obry.org>, Steve Sangwine <sjs@essex.ac.uk> diff --git a/compat/zlib/contrib/ada/test.adb b/compat/zlib/contrib/ada/test.adb new file mode 100644 index 0000000..11a92d7 --- /dev/null +++ b/compat/zlib/contrib/ada/test.adb @@ -0,0 +1,463 @@ +---------------------------------------------------------------- +-- ZLib for Ada thick binding. -- +-- -- +-- Copyright (C) 2002-2003 Dmitriy Anisimkov -- +-- -- +-- Open source license information is in the zlib.ads file. -- +---------------------------------------------------------------- + +-- $Id: test.adb,v 1.1 2008/12/19 14:44:49 dkf Exp $ + +-- The program has a few aims. +-- 1. Test ZLib.Ada95 thick binding functionality. +-- 2. Show the example of use main functionality of the ZLib.Ada95 binding. +-- 3. Build this program automatically compile all ZLib.Ada95 packages under +-- GNAT Ada95 compiler. + +with ZLib.Streams; +with Ada.Streams.Stream_IO; +with Ada.Numerics.Discrete_Random; + +with Ada.Text_IO; + +with Ada.Calendar; + +procedure Test is + + use Ada.Streams; + use Stream_IO; + + ------------------------------------ + -- Test configuration parameters -- + ------------------------------------ + + File_Size : Count := 100_000; + Continuous : constant Boolean := False; + + Header : constant ZLib.Header_Type := ZLib.Default; + -- ZLib.None; + -- ZLib.Auto; + -- ZLib.GZip; + -- Do not use Header other then Default in ZLib versions 1.1.4 + -- and older. + + Strategy : constant ZLib.Strategy_Type := ZLib.Default_Strategy; + Init_Random : constant := 10; + + -- End -- + + In_File_Name : constant String := "testzlib.in"; + -- Name of the input file + + Z_File_Name : constant String := "testzlib.zlb"; + -- Name of the compressed file. + + Out_File_Name : constant String := "testzlib.out"; + -- Name of the decompressed file. + + File_In : File_Type; + File_Out : File_Type; + File_Back : File_Type; + File_Z : ZLib.Streams.Stream_Type; + + Filter : ZLib.Filter_Type; + + Time_Stamp : Ada.Calendar.Time; + + procedure Generate_File; + -- Generate file of spetsified size with some random data. + -- The random data is repeatable, for the good compression. + + procedure Compare_Streams + (Left, Right : in out Root_Stream_Type'Class); + -- The procedure compearing data in 2 streams. + -- It is for compare data before and after compression/decompression. + + procedure Compare_Files (Left, Right : String); + -- Compare files. Based on the Compare_Streams. + + procedure Copy_Streams + (Source, Target : in out Root_Stream_Type'Class; + Buffer_Size : in Stream_Element_Offset := 1024); + -- Copying data from one stream to another. It is for test stream + -- interface of the library. + + procedure Data_In + (Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + -- this procedure is for generic instantiation of + -- ZLib.Generic_Translate. + -- reading data from the File_In. + + procedure Data_Out (Item : in Stream_Element_Array); + -- this procedure is for generic instantiation of + -- ZLib.Generic_Translate. + -- writing data to the File_Out. + + procedure Stamp; + -- Store the timestamp to the local variable. + + procedure Print_Statistic (Msg : String; Data_Size : ZLib.Count); + -- Print the time statistic with the message. + + procedure Translate is new ZLib.Generic_Translate + (Data_In => Data_In, + Data_Out => Data_Out); + -- This procedure is moving data from File_In to File_Out + -- with compression or decompression, depend on initialization of + -- Filter parameter. + + ------------------- + -- Compare_Files -- + ------------------- + + procedure Compare_Files (Left, Right : String) is + Left_File, Right_File : File_Type; + begin + Open (Left_File, In_File, Left); + Open (Right_File, In_File, Right); + Compare_Streams (Stream (Left_File).all, Stream (Right_File).all); + Close (Left_File); + Close (Right_File); + end Compare_Files; + + --------------------- + -- Compare_Streams -- + --------------------- + + procedure Compare_Streams + (Left, Right : in out Ada.Streams.Root_Stream_Type'Class) + is + Left_Buffer, Right_Buffer : Stream_Element_Array (0 .. 16#FFF#); + Left_Last, Right_Last : Stream_Element_Offset; + begin + loop + Read (Left, Left_Buffer, Left_Last); + Read (Right, Right_Buffer, Right_Last); + + if Left_Last /= Right_Last then + Ada.Text_IO.Put_Line ("Compare error :" + & Stream_Element_Offset'Image (Left_Last) + & " /= " + & Stream_Element_Offset'Image (Right_Last)); + + raise Constraint_Error; + + elsif Left_Buffer (0 .. Left_Last) + /= Right_Buffer (0 .. Right_Last) + then + Ada.Text_IO.Put_Line ("ERROR: IN and OUT files is not equal."); + raise Constraint_Error; + + end if; + + exit when Left_Last < Left_Buffer'Last; + end loop; + end Compare_Streams; + + ------------------ + -- Copy_Streams -- + ------------------ + + procedure Copy_Streams + (Source, Target : in out Ada.Streams.Root_Stream_Type'Class; + Buffer_Size : in Stream_Element_Offset := 1024) + is + Buffer : Stream_Element_Array (1 .. Buffer_Size); + Last : Stream_Element_Offset; + begin + loop + Read (Source, Buffer, Last); + Write (Target, Buffer (1 .. Last)); + + exit when Last < Buffer'Last; + end loop; + end Copy_Streams; + + ------------- + -- Data_In -- + ------------- + + procedure Data_In + (Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + begin + Read (File_In, Item, Last); + end Data_In; + + -------------- + -- Data_Out -- + -------------- + + procedure Data_Out (Item : in Stream_Element_Array) is + begin + Write (File_Out, Item); + end Data_Out; + + ------------------- + -- Generate_File -- + ------------------- + + procedure Generate_File is + subtype Visible_Symbols is Stream_Element range 16#20# .. 16#7E#; + + package Random_Elements is + new Ada.Numerics.Discrete_Random (Visible_Symbols); + + Gen : Random_Elements.Generator; + Buffer : Stream_Element_Array := (1 .. 77 => 16#20#) & 10; + + Buffer_Count : constant Count := File_Size / Buffer'Length; + -- Number of same buffers in the packet. + + Density : constant Count := 30; -- from 0 to Buffer'Length - 2; + + procedure Fill_Buffer (J, D : in Count); + -- Change the part of the buffer. + + ----------------- + -- Fill_Buffer -- + ----------------- + + procedure Fill_Buffer (J, D : in Count) is + begin + for K in 0 .. D loop + Buffer + (Stream_Element_Offset ((J + K) mod (Buffer'Length - 1) + 1)) + := Random_Elements.Random (Gen); + + end loop; + end Fill_Buffer; + + begin + Random_Elements.Reset (Gen, Init_Random); + + Create (File_In, Out_File, In_File_Name); + + Fill_Buffer (1, Buffer'Length - 2); + + for J in 1 .. Buffer_Count loop + Write (File_In, Buffer); + + Fill_Buffer (J, Density); + end loop; + + -- fill remain size. + + Write + (File_In, + Buffer + (1 .. Stream_Element_Offset + (File_Size - Buffer'Length * Buffer_Count))); + + Flush (File_In); + Close (File_In); + end Generate_File; + + --------------------- + -- Print_Statistic -- + --------------------- + + procedure Print_Statistic (Msg : String; Data_Size : ZLib.Count) is + use Ada.Calendar; + use Ada.Text_IO; + + package Count_IO is new Integer_IO (ZLib.Count); + + Curr_Dur : Duration := Clock - Time_Stamp; + begin + Put (Msg); + + Set_Col (20); + Ada.Text_IO.Put ("size ="); + + Count_IO.Put + (Data_Size, + Width => Stream_IO.Count'Image (File_Size)'Length); + + Put_Line (" duration =" & Duration'Image (Curr_Dur)); + end Print_Statistic; + + ----------- + -- Stamp -- + ----------- + + procedure Stamp is + begin + Time_Stamp := Ada.Calendar.Clock; + end Stamp; + +begin + Ada.Text_IO.Put_Line ("ZLib " & ZLib.Version); + + loop + Generate_File; + + for Level in ZLib.Compression_Level'Range loop + + Ada.Text_IO.Put_Line ("Level =" + & ZLib.Compression_Level'Image (Level)); + + -- Test generic interface. + Open (File_In, In_File, In_File_Name); + Create (File_Out, Out_File, Z_File_Name); + + Stamp; + + -- Deflate using generic instantiation. + + ZLib.Deflate_Init + (Filter => Filter, + Level => Level, + Strategy => Strategy, + Header => Header); + + Translate (Filter); + Print_Statistic ("Generic compress", ZLib.Total_Out (Filter)); + ZLib.Close (Filter); + + Close (File_In); + Close (File_Out); + + Open (File_In, In_File, Z_File_Name); + Create (File_Out, Out_File, Out_File_Name); + + Stamp; + + -- Inflate using generic instantiation. + + ZLib.Inflate_Init (Filter, Header => Header); + + Translate (Filter); + Print_Statistic ("Generic decompress", ZLib.Total_Out (Filter)); + + ZLib.Close (Filter); + + Close (File_In); + Close (File_Out); + + Compare_Files (In_File_Name, Out_File_Name); + + -- Test stream interface. + + -- Compress to the back stream. + + Open (File_In, In_File, In_File_Name); + Create (File_Back, Out_File, Z_File_Name); + + Stamp; + + ZLib.Streams.Create + (Stream => File_Z, + Mode => ZLib.Streams.Out_Stream, + Back => ZLib.Streams.Stream_Access + (Stream (File_Back)), + Back_Compressed => True, + Level => Level, + Strategy => Strategy, + Header => Header); + + Copy_Streams + (Source => Stream (File_In).all, + Target => File_Z); + + -- Flushing internal buffers to the back stream. + + ZLib.Streams.Flush (File_Z, ZLib.Finish); + + Print_Statistic ("Write compress", + ZLib.Streams.Write_Total_Out (File_Z)); + + ZLib.Streams.Close (File_Z); + + Close (File_In); + Close (File_Back); + + -- Compare reading from original file and from + -- decompression stream. + + Open (File_In, In_File, In_File_Name); + Open (File_Back, In_File, Z_File_Name); + + ZLib.Streams.Create + (Stream => File_Z, + Mode => ZLib.Streams.In_Stream, + Back => ZLib.Streams.Stream_Access + (Stream (File_Back)), + Back_Compressed => True, + Header => Header); + + Stamp; + Compare_Streams (Stream (File_In).all, File_Z); + + Print_Statistic ("Read decompress", + ZLib.Streams.Read_Total_Out (File_Z)); + + ZLib.Streams.Close (File_Z); + Close (File_In); + Close (File_Back); + + -- Compress by reading from compression stream. + + Open (File_Back, In_File, In_File_Name); + Create (File_Out, Out_File, Z_File_Name); + + ZLib.Streams.Create + (Stream => File_Z, + Mode => ZLib.Streams.In_Stream, + Back => ZLib.Streams.Stream_Access + (Stream (File_Back)), + Back_Compressed => False, + Level => Level, + Strategy => Strategy, + Header => Header); + + Stamp; + Copy_Streams + (Source => File_Z, + Target => Stream (File_Out).all); + + Print_Statistic ("Read compress", + ZLib.Streams.Read_Total_Out (File_Z)); + + ZLib.Streams.Close (File_Z); + + Close (File_Out); + Close (File_Back); + + -- Decompress to decompression stream. + + Open (File_In, In_File, Z_File_Name); + Create (File_Back, Out_File, Out_File_Name); + + ZLib.Streams.Create + (Stream => File_Z, + Mode => ZLib.Streams.Out_Stream, + Back => ZLib.Streams.Stream_Access + (Stream (File_Back)), + Back_Compressed => False, + Header => Header); + + Stamp; + + Copy_Streams + (Source => Stream (File_In).all, + Target => File_Z); + + Print_Statistic ("Write decompress", + ZLib.Streams.Write_Total_Out (File_Z)); + + ZLib.Streams.Close (File_Z); + Close (File_In); + Close (File_Back); + + Compare_Files (In_File_Name, Out_File_Name); + end loop; + + Ada.Text_IO.Put_Line (Count'Image (File_Size) & " Ok."); + + exit when not Continuous; + + File_Size := File_Size + 1; + end loop; +end Test; diff --git a/compat/zlib/contrib/ada/zlib-streams.adb b/compat/zlib/contrib/ada/zlib-streams.adb new file mode 100644 index 0000000..e90ed11 --- /dev/null +++ b/compat/zlib/contrib/ada/zlib-streams.adb @@ -0,0 +1,225 @@ +---------------------------------------------------------------- +-- ZLib for Ada thick binding. -- +-- -- +-- Copyright (C) 2002-2003 Dmitriy Anisimkov -- +-- -- +-- Open source license information is in the zlib.ads file. -- +---------------------------------------------------------------- + +-- $Id: zlib-streams.adb,v 1.1 2008/12/19 14:44:49 dkf Exp $ + +with Ada.Unchecked_Deallocation; + +package body ZLib.Streams is + + ----------- + -- Close -- + ----------- + + procedure Close (Stream : in out Stream_Type) is + procedure Free is new Ada.Unchecked_Deallocation + (Stream_Element_Array, Buffer_Access); + begin + if Stream.Mode = Out_Stream or Stream.Mode = Duplex then + -- We should flush the data written by the writer. + + Flush (Stream, Finish); + + Close (Stream.Writer); + end if; + + if Stream.Mode = In_Stream or Stream.Mode = Duplex then + Close (Stream.Reader); + Free (Stream.Buffer); + end if; + end Close; + + ------------ + -- Create -- + ------------ + + procedure Create + (Stream : out Stream_Type; + Mode : in Stream_Mode; + Back : in Stream_Access; + Back_Compressed : in Boolean; + Level : in Compression_Level := Default_Compression; + Strategy : in Strategy_Type := Default_Strategy; + Header : in Header_Type := Default; + Read_Buffer_Size : in Ada.Streams.Stream_Element_Offset + := Default_Buffer_Size; + Write_Buffer_Size : in Ada.Streams.Stream_Element_Offset + := Default_Buffer_Size) + is + + subtype Buffer_Subtype is Stream_Element_Array (1 .. Read_Buffer_Size); + + procedure Init_Filter + (Filter : in out Filter_Type; + Compress : in Boolean); + + ----------------- + -- Init_Filter -- + ----------------- + + procedure Init_Filter + (Filter : in out Filter_Type; + Compress : in Boolean) is + begin + if Compress then + Deflate_Init + (Filter, Level, Strategy, Header => Header); + else + Inflate_Init (Filter, Header => Header); + end if; + end Init_Filter; + + begin + Stream.Back := Back; + Stream.Mode := Mode; + + if Mode = Out_Stream or Mode = Duplex then + Init_Filter (Stream.Writer, Back_Compressed); + Stream.Buffer_Size := Write_Buffer_Size; + else + Stream.Buffer_Size := 0; + end if; + + if Mode = In_Stream or Mode = Duplex then + Init_Filter (Stream.Reader, not Back_Compressed); + + Stream.Buffer := new Buffer_Subtype; + Stream.Rest_First := Stream.Buffer'Last + 1; + Stream.Rest_Last := Stream.Buffer'Last; + end if; + end Create; + + ----------- + -- Flush -- + ----------- + + procedure Flush + (Stream : in out Stream_Type; + Mode : in Flush_Mode := Sync_Flush) + is + Buffer : Stream_Element_Array (1 .. Stream.Buffer_Size); + Last : Stream_Element_Offset; + begin + loop + Flush (Stream.Writer, Buffer, Last, Mode); + + Ada.Streams.Write (Stream.Back.all, Buffer (1 .. Last)); + + exit when Last < Buffer'Last; + end loop; + end Flush; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (Stream : Stream_Type) return Boolean is + begin + return Is_Open (Stream.Reader) or else Is_Open (Stream.Writer); + end Is_Open; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Stream_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + + procedure Read + (Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + + ---------- + -- Read -- + ---------- + + procedure Read + (Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + begin + Ada.Streams.Read (Stream.Back.all, Item, Last); + end Read; + + procedure Read is new ZLib.Read + (Read => Read, + Buffer => Stream.Buffer.all, + Rest_First => Stream.Rest_First, + Rest_Last => Stream.Rest_Last); + + begin + Read (Stream.Reader, Item, Last); + end Read; + + ------------------- + -- Read_Total_In -- + ------------------- + + function Read_Total_In (Stream : in Stream_Type) return Count is + begin + return Total_In (Stream.Reader); + end Read_Total_In; + + -------------------- + -- Read_Total_Out -- + -------------------- + + function Read_Total_Out (Stream : in Stream_Type) return Count is + begin + return Total_Out (Stream.Reader); + end Read_Total_Out; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Stream_Type; + Item : in Stream_Element_Array) + is + + procedure Write (Item : in Stream_Element_Array); + + ----------- + -- Write -- + ----------- + + procedure Write (Item : in Stream_Element_Array) is + begin + Ada.Streams.Write (Stream.Back.all, Item); + end Write; + + procedure Write is new ZLib.Write + (Write => Write, + Buffer_Size => Stream.Buffer_Size); + + begin + Write (Stream.Writer, Item, No_Flush); + end Write; + + -------------------- + -- Write_Total_In -- + -------------------- + + function Write_Total_In (Stream : in Stream_Type) return Count is + begin + return Total_In (Stream.Writer); + end Write_Total_In; + + --------------------- + -- Write_Total_Out -- + --------------------- + + function Write_Total_Out (Stream : in Stream_Type) return Count is + begin + return Total_Out (Stream.Writer); + end Write_Total_Out; + +end ZLib.Streams; diff --git a/compat/zlib/contrib/ada/zlib-streams.ads b/compat/zlib/contrib/ada/zlib-streams.ads new file mode 100644 index 0000000..aeb06b5 --- /dev/null +++ b/compat/zlib/contrib/ada/zlib-streams.ads @@ -0,0 +1,114 @@ +---------------------------------------------------------------- +-- ZLib for Ada thick binding. -- +-- -- +-- Copyright (C) 2002-2003 Dmitriy Anisimkov -- +-- -- +-- Open source license information is in the zlib.ads file. -- +---------------------------------------------------------------- + +-- $Id: zlib-streams.ads,v 1.1 2008/12/19 14:44:49 dkf Exp $ + +package ZLib.Streams is + + type Stream_Mode is (In_Stream, Out_Stream, Duplex); + + type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class; + + type Stream_Type is + new Ada.Streams.Root_Stream_Type with private; + + procedure Read + (Stream : in out Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Stream_Type; + Item : in Ada.Streams.Stream_Element_Array); + + procedure Flush + (Stream : in out Stream_Type; + Mode : in Flush_Mode := Sync_Flush); + -- Flush the written data to the back stream, + -- all data placed to the compressor is flushing to the Back stream. + -- Should not be used untill necessary, becouse it is decreasing + -- compression. + + function Read_Total_In (Stream : in Stream_Type) return Count; + pragma Inline (Read_Total_In); + -- Return total number of bytes read from back stream so far. + + function Read_Total_Out (Stream : in Stream_Type) return Count; + pragma Inline (Read_Total_Out); + -- Return total number of bytes read so far. + + function Write_Total_In (Stream : in Stream_Type) return Count; + pragma Inline (Write_Total_In); + -- Return total number of bytes written so far. + + function Write_Total_Out (Stream : in Stream_Type) return Count; + pragma Inline (Write_Total_Out); + -- Return total number of bytes written to the back stream. + + procedure Create + (Stream : out Stream_Type; + Mode : in Stream_Mode; + Back : in Stream_Access; + Back_Compressed : in Boolean; + Level : in Compression_Level := Default_Compression; + Strategy : in Strategy_Type := Default_Strategy; + Header : in Header_Type := Default; + Read_Buffer_Size : in Ada.Streams.Stream_Element_Offset + := Default_Buffer_Size; + Write_Buffer_Size : in Ada.Streams.Stream_Element_Offset + := Default_Buffer_Size); + -- Create the Comression/Decompression stream. + -- If mode is In_Stream then Write operation is disabled. + -- If mode is Out_Stream then Read operation is disabled. + + -- If Back_Compressed is true then + -- Data written to the Stream is compressing to the Back stream + -- and data read from the Stream is decompressed data from the Back stream. + + -- If Back_Compressed is false then + -- Data written to the Stream is decompressing to the Back stream + -- and data read from the Stream is compressed data from the Back stream. + + -- !!! When the Need_Header is False ZLib-Ada is using undocumented + -- ZLib 1.1.4 functionality to do not create/wait for ZLib headers. + + function Is_Open (Stream : Stream_Type) return Boolean; + + procedure Close (Stream : in out Stream_Type); + +private + + use Ada.Streams; + + type Buffer_Access is access all Stream_Element_Array; + + type Stream_Type + is new Root_Stream_Type with + record + Mode : Stream_Mode; + + Buffer : Buffer_Access; + Rest_First : Stream_Element_Offset; + Rest_Last : Stream_Element_Offset; + -- Buffer for Read operation. + -- We need to have this buffer in the record + -- becouse not all read data from back stream + -- could be processed during the read operation. + + Buffer_Size : Stream_Element_Offset; + -- Buffer size for write operation. + -- We do not need to have this buffer + -- in the record becouse all data could be + -- processed in the write operation. + + Back : Stream_Access; + Reader : Filter_Type; + Writer : Filter_Type; + end record; + +end ZLib.Streams; diff --git a/compat/zlib/contrib/ada/zlib-thin.adb b/compat/zlib/contrib/ada/zlib-thin.adb new file mode 100644 index 0000000..941f5d0 --- /dev/null +++ b/compat/zlib/contrib/ada/zlib-thin.adb @@ -0,0 +1,141 @@ +---------------------------------------------------------------- +-- ZLib for Ada thick binding. -- +-- -- +-- Copyright (C) 2002-2003 Dmitriy Anisimkov -- +-- -- +-- Open source license information is in the zlib.ads file. -- +---------------------------------------------------------------- + +-- $Id: zlib-thin.adb,v 1.1 2008/12/19 14:44:49 dkf Exp $ + +package body ZLib.Thin is + + ZLIB_VERSION : constant Chars_Ptr := zlibVersion; + + Z_Stream_Size : constant Int := Z_Stream'Size / System.Storage_Unit; + + -------------- + -- Avail_In -- + -------------- + + function Avail_In (Strm : in Z_Stream) return UInt is + begin + return Strm.Avail_In; + end Avail_In; + + --------------- + -- Avail_Out -- + --------------- + + function Avail_Out (Strm : in Z_Stream) return UInt is + begin + return Strm.Avail_Out; + end Avail_Out; + + ------------------ + -- Deflate_Init -- + ------------------ + + function Deflate_Init + (strm : Z_Streamp; + level : Int; + method : Int; + windowBits : Int; + memLevel : Int; + strategy : Int) + return Int is + begin + return deflateInit2 + (strm, + level, + method, + windowBits, + memLevel, + strategy, + ZLIB_VERSION, + Z_Stream_Size); + end Deflate_Init; + + ------------------ + -- Inflate_Init -- + ------------------ + + function Inflate_Init (strm : Z_Streamp; windowBits : Int) return Int is + begin + return inflateInit2 (strm, windowBits, ZLIB_VERSION, Z_Stream_Size); + end Inflate_Init; + + ------------------------ + -- Last_Error_Message -- + ------------------------ + + function Last_Error_Message (Strm : in Z_Stream) return String is + use Interfaces.C.Strings; + begin + if Strm.msg = Null_Ptr then + return ""; + else + return Value (Strm.msg); + end if; + end Last_Error_Message; + + ------------ + -- Set_In -- + ------------ + + procedure Set_In + (Strm : in out Z_Stream; + Buffer : in Voidp; + Size : in UInt) is + begin + Strm.Next_In := Buffer; + Strm.Avail_In := Size; + end Set_In; + + ------------------ + -- Set_Mem_Func -- + ------------------ + + procedure Set_Mem_Func + (Strm : in out Z_Stream; + Opaque : in Voidp; + Alloc : in alloc_func; + Free : in free_func) is + begin + Strm.opaque := Opaque; + Strm.zalloc := Alloc; + Strm.zfree := Free; + end Set_Mem_Func; + + ------------- + -- Set_Out -- + ------------- + + procedure Set_Out + (Strm : in out Z_Stream; + Buffer : in Voidp; + Size : in UInt) is + begin + Strm.Next_Out := Buffer; + Strm.Avail_Out := Size; + end Set_Out; + + -------------- + -- Total_In -- + -------------- + + function Total_In (Strm : in Z_Stream) return ULong is + begin + return Strm.Total_In; + end Total_In; + + --------------- + -- Total_Out -- + --------------- + + function Total_Out (Strm : in Z_Stream) return ULong is + begin + return Strm.Total_Out; + end Total_Out; + +end ZLib.Thin; diff --git a/compat/zlib/contrib/ada/zlib-thin.ads b/compat/zlib/contrib/ada/zlib-thin.ads new file mode 100644 index 0000000..b38fc7c --- /dev/null +++ b/compat/zlib/contrib/ada/zlib-thin.ads @@ -0,0 +1,450 @@ +---------------------------------------------------------------- +-- ZLib for Ada thick binding. -- +-- -- +-- Copyright (C) 2002-2003 Dmitriy Anisimkov -- +-- -- +-- Open source license information is in the zlib.ads file. -- +---------------------------------------------------------------- + +-- $Id: zlib-thin.ads,v 1.1 2008/12/19 14:44:49 dkf Exp $ + +with Interfaces.C.Strings; + +with System; + +private package ZLib.Thin is + + -- From zconf.h + + MAX_MEM_LEVEL : constant := 9; -- zconf.h:105 + -- zconf.h:105 + MAX_WBITS : constant := 15; -- zconf.h:115 + -- 32K LZ77 window + -- zconf.h:115 + SEEK_SET : constant := 8#0000#; -- zconf.h:244 + -- Seek from beginning of file. + -- zconf.h:244 + SEEK_CUR : constant := 1; -- zconf.h:245 + -- Seek from current position. + -- zconf.h:245 + SEEK_END : constant := 2; -- zconf.h:246 + -- Set file pointer to EOF plus "offset" + -- zconf.h:246 + + type Byte is new Interfaces.C.unsigned_char; -- 8 bits + -- zconf.h:214 + type UInt is new Interfaces.C.unsigned; -- 16 bits or more + -- zconf.h:216 + type Int is new Interfaces.C.int; + + type ULong is new Interfaces.C.unsigned_long; -- 32 bits or more + -- zconf.h:217 + subtype Chars_Ptr is Interfaces.C.Strings.chars_ptr; + + type ULong_Access is access ULong; + type Int_Access is access Int; + + subtype Voidp is System.Address; -- zconf.h:232 + + subtype Byte_Access is Voidp; + + Nul : constant Voidp := System.Null_Address; + -- end from zconf + + Z_NO_FLUSH : constant := 8#0000#; -- zlib.h:125 + -- zlib.h:125 + Z_PARTIAL_FLUSH : constant := 1; -- zlib.h:126 + -- will be removed, use + -- Z_SYNC_FLUSH instead + -- zlib.h:126 + Z_SYNC_FLUSH : constant := 2; -- zlib.h:127 + -- zlib.h:127 + Z_FULL_FLUSH : constant := 3; -- zlib.h:128 + -- zlib.h:128 + Z_FINISH : constant := 4; -- zlib.h:129 + -- zlib.h:129 + Z_OK : constant := 8#0000#; -- zlib.h:132 + -- zlib.h:132 + Z_STREAM_END : constant := 1; -- zlib.h:133 + -- zlib.h:133 + Z_NEED_DICT : constant := 2; -- zlib.h:134 + -- zlib.h:134 + Z_ERRNO : constant := -1; -- zlib.h:135 + -- zlib.h:135 + Z_STREAM_ERROR : constant := -2; -- zlib.h:136 + -- zlib.h:136 + Z_DATA_ERROR : constant := -3; -- zlib.h:137 + -- zlib.h:137 + Z_MEM_ERROR : constant := -4; -- zlib.h:138 + -- zlib.h:138 + Z_BUF_ERROR : constant := -5; -- zlib.h:139 + -- zlib.h:139 + Z_VERSION_ERROR : constant := -6; -- zlib.h:140 + -- zlib.h:140 + Z_NO_COMPRESSION : constant := 8#0000#; -- zlib.h:145 + -- zlib.h:145 + Z_BEST_SPEED : constant := 1; -- zlib.h:146 + -- zlib.h:146 + Z_BEST_COMPRESSION : constant := 9; -- zlib.h:147 + -- zlib.h:147 + Z_DEFAULT_COMPRESSION : constant := -1; -- zlib.h:148 + -- zlib.h:148 + Z_FILTERED : constant := 1; -- zlib.h:151 + -- zlib.h:151 + Z_HUFFMAN_ONLY : constant := 2; -- zlib.h:152 + -- zlib.h:152 + Z_DEFAULT_STRATEGY : constant := 8#0000#; -- zlib.h:153 + -- zlib.h:153 + Z_BINARY : constant := 8#0000#; -- zlib.h:156 + -- zlib.h:156 + Z_ASCII : constant := 1; -- zlib.h:157 + -- zlib.h:157 + Z_UNKNOWN : constant := 2; -- zlib.h:158 + -- zlib.h:158 + Z_DEFLATED : constant := 8; -- zlib.h:161 + -- zlib.h:161 + Z_NULL : constant := 8#0000#; -- zlib.h:164 + -- for initializing zalloc, zfree, opaque + -- zlib.h:164 + type gzFile is new Voidp; -- zlib.h:646 + + type Z_Stream is private; + + type Z_Streamp is access all Z_Stream; -- zlib.h:89 + + type alloc_func is access function + (Opaque : Voidp; + Items : UInt; + Size : UInt) + return Voidp; -- zlib.h:63 + + type free_func is access procedure (opaque : Voidp; address : Voidp); + + function zlibVersion return Chars_Ptr; + + function Deflate (strm : Z_Streamp; flush : Int) return Int; + + function DeflateEnd (strm : Z_Streamp) return Int; + + function Inflate (strm : Z_Streamp; flush : Int) return Int; + + function InflateEnd (strm : Z_Streamp) return Int; + + function deflateSetDictionary + (strm : Z_Streamp; + dictionary : Byte_Access; + dictLength : UInt) + return Int; + + function deflateCopy (dest : Z_Streamp; source : Z_Streamp) return Int; + -- zlib.h:478 + + function deflateReset (strm : Z_Streamp) return Int; -- zlib.h:495 + + function deflateParams + (strm : Z_Streamp; + level : Int; + strategy : Int) + return Int; -- zlib.h:506 + + function inflateSetDictionary + (strm : Z_Streamp; + dictionary : Byte_Access; + dictLength : UInt) + return Int; -- zlib.h:548 + + function inflateSync (strm : Z_Streamp) return Int; -- zlib.h:565 + + function inflateReset (strm : Z_Streamp) return Int; -- zlib.h:580 + + function compress + (dest : Byte_Access; + destLen : ULong_Access; + source : Byte_Access; + sourceLen : ULong) + return Int; -- zlib.h:601 + + function compress2 + (dest : Byte_Access; + destLen : ULong_Access; + source : Byte_Access; + sourceLen : ULong; + level : Int) + return Int; -- zlib.h:615 + + function uncompress + (dest : Byte_Access; + destLen : ULong_Access; + source : Byte_Access; + sourceLen : ULong) + return Int; + + function gzopen (path : Chars_Ptr; mode : Chars_Ptr) return gzFile; + + function gzdopen (fd : Int; mode : Chars_Ptr) return gzFile; + + function gzsetparams + (file : gzFile; + level : Int; + strategy : Int) + return Int; + + function gzread + (file : gzFile; + buf : Voidp; + len : UInt) + return Int; + + function gzwrite + (file : in gzFile; + buf : in Voidp; + len : in UInt) + return Int; + + function gzprintf (file : in gzFile; format : in Chars_Ptr) return Int; + + function gzputs (file : in gzFile; s : in Chars_Ptr) return Int; + + function gzgets + (file : gzFile; + buf : Chars_Ptr; + len : Int) + return Chars_Ptr; + + function gzputc (file : gzFile; char : Int) return Int; + + function gzgetc (file : gzFile) return Int; + + function gzflush (file : gzFile; flush : Int) return Int; + + function gzseek + (file : gzFile; + offset : Int; + whence : Int) + return Int; + + function gzrewind (file : gzFile) return Int; + + function gztell (file : gzFile) return Int; + + function gzeof (file : gzFile) return Int; + + function gzclose (file : gzFile) return Int; + + function gzerror (file : gzFile; errnum : Int_Access) return Chars_Ptr; + + function adler32 + (adler : ULong; + buf : Byte_Access; + len : UInt) + return ULong; + + function crc32 + (crc : ULong; + buf : Byte_Access; + len : UInt) + return ULong; + + function deflateInit + (strm : Z_Streamp; + level : Int; + version : Chars_Ptr; + stream_size : Int) + return Int; + + function deflateInit2 + (strm : Z_Streamp; + level : Int; + method : Int; + windowBits : Int; + memLevel : Int; + strategy : Int; + version : Chars_Ptr; + stream_size : Int) + return Int; + + function Deflate_Init + (strm : Z_Streamp; + level : Int; + method : Int; + windowBits : Int; + memLevel : Int; + strategy : Int) + return Int; + pragma Inline (Deflate_Init); + + function inflateInit + (strm : Z_Streamp; + version : Chars_Ptr; + stream_size : Int) + return Int; + + function inflateInit2 + (strm : in Z_Streamp; + windowBits : in Int; + version : in Chars_Ptr; + stream_size : in Int) + return Int; + + function inflateBackInit + (strm : in Z_Streamp; + windowBits : in Int; + window : in Byte_Access; + version : in Chars_Ptr; + stream_size : in Int) + return Int; + -- Size of window have to be 2**windowBits. + + function Inflate_Init (strm : Z_Streamp; windowBits : Int) return Int; + pragma Inline (Inflate_Init); + + function zError (err : Int) return Chars_Ptr; + + function inflateSyncPoint (z : Z_Streamp) return Int; + + function get_crc_table return ULong_Access; + + -- Interface to the available fields of the z_stream structure. + -- The application must update next_in and avail_in when avail_in has + -- dropped to zero. It must update next_out and avail_out when avail_out + -- has dropped to zero. The application must initialize zalloc, zfree and + -- opaque before calling the init function. + + procedure Set_In + (Strm : in out Z_Stream; + Buffer : in Voidp; + Size : in UInt); + pragma Inline (Set_In); + + procedure Set_Out + (Strm : in out Z_Stream; + Buffer : in Voidp; + Size : in UInt); + pragma Inline (Set_Out); + + procedure Set_Mem_Func + (Strm : in out Z_Stream; + Opaque : in Voidp; + Alloc : in alloc_func; + Free : in free_func); + pragma Inline (Set_Mem_Func); + + function Last_Error_Message (Strm : in Z_Stream) return String; + pragma Inline (Last_Error_Message); + + function Avail_Out (Strm : in Z_Stream) return UInt; + pragma Inline (Avail_Out); + + function Avail_In (Strm : in Z_Stream) return UInt; + pragma Inline (Avail_In); + + function Total_In (Strm : in Z_Stream) return ULong; + pragma Inline (Total_In); + + function Total_Out (Strm : in Z_Stream) return ULong; + pragma Inline (Total_Out); + + function inflateCopy + (dest : in Z_Streamp; + Source : in Z_Streamp) + return Int; + + function compressBound (Source_Len : in ULong) return ULong; + + function deflateBound + (Strm : in Z_Streamp; + Source_Len : in ULong) + return ULong; + + function gzungetc (C : in Int; File : in gzFile) return Int; + + function zlibCompileFlags return ULong; + +private + + type Z_Stream is record -- zlib.h:68 + Next_In : Voidp := Nul; -- next input byte + Avail_In : UInt := 0; -- number of bytes available at next_in + Total_In : ULong := 0; -- total nb of input bytes read so far + Next_Out : Voidp := Nul; -- next output byte should be put there + Avail_Out : UInt := 0; -- remaining free space at next_out + Total_Out : ULong := 0; -- total nb of bytes output so far + msg : Chars_Ptr; -- last error message, NULL if no error + state : Voidp; -- not visible by applications + zalloc : alloc_func := null; -- used to allocate the internal state + zfree : free_func := null; -- used to free the internal state + opaque : Voidp; -- private data object passed to + -- zalloc and zfree + data_type : Int; -- best guess about the data type: + -- ascii or binary + adler : ULong; -- adler32 value of the uncompressed + -- data + reserved : ULong; -- reserved for future use + end record; + + pragma Convention (C, Z_Stream); + + pragma Import (C, zlibVersion, "zlibVersion"); + pragma Import (C, Deflate, "deflate"); + pragma Import (C, DeflateEnd, "deflateEnd"); + pragma Import (C, Inflate, "inflate"); + pragma Import (C, InflateEnd, "inflateEnd"); + pragma Import (C, deflateSetDictionary, "deflateSetDictionary"); + pragma Import (C, deflateCopy, "deflateCopy"); + pragma Import (C, deflateReset, "deflateReset"); + pragma Import (C, deflateParams, "deflateParams"); + pragma Import (C, inflateSetDictionary, "inflateSetDictionary"); + pragma Import (C, inflateSync, "inflateSync"); + pragma Import (C, inflateReset, "inflateReset"); + pragma Import (C, compress, "compress"); + pragma Import (C, compress2, "compress2"); + pragma Import (C, uncompress, "uncompress"); + pragma Import (C, gzopen, "gzopen"); + pragma Import (C, gzdopen, "gzdopen"); + pragma Import (C, gzsetparams, "gzsetparams"); + pragma Import (C, gzread, "gzread"); + pragma Import (C, gzwrite, "gzwrite"); + pragma Import (C, gzprintf, "gzprintf"); + pragma Import (C, gzputs, "gzputs"); + pragma Import (C, gzgets, "gzgets"); + pragma Import (C, gzputc, "gzputc"); + pragma Import (C, gzgetc, "gzgetc"); + pragma Import (C, gzflush, "gzflush"); + pragma Import (C, gzseek, "gzseek"); + pragma Import (C, gzrewind, "gzrewind"); + pragma Import (C, gztell, "gztell"); + pragma Import (C, gzeof, "gzeof"); + pragma Import (C, gzclose, "gzclose"); + pragma Import (C, gzerror, "gzerror"); + pragma Import (C, adler32, "adler32"); + pragma Import (C, crc32, "crc32"); + pragma Import (C, deflateInit, "deflateInit_"); + pragma Import (C, inflateInit, "inflateInit_"); + pragma Import (C, deflateInit2, "deflateInit2_"); + pragma Import (C, inflateInit2, "inflateInit2_"); + pragma Import (C, zError, "zError"); + pragma Import (C, inflateSyncPoint, "inflateSyncPoint"); + pragma Import (C, get_crc_table, "get_crc_table"); + + -- since zlib 1.2.0: + + pragma Import (C, inflateCopy, "inflateCopy"); + pragma Import (C, compressBound, "compressBound"); + pragma Import (C, deflateBound, "deflateBound"); + pragma Import (C, gzungetc, "gzungetc"); + pragma Import (C, zlibCompileFlags, "zlibCompileFlags"); + + pragma Import (C, inflateBackInit, "inflateBackInit_"); + + -- I stopped binding the inflateBack routines, becouse realize that + -- it does not support zlib and gzip headers for now, and have no + -- symmetric deflateBack routines. + -- ZLib-Ada is symmetric regarding deflate/inflate data transformation + -- and has a similar generic callback interface for the + -- deflate/inflate transformation based on the regular Deflate/Inflate + -- routines. + + -- pragma Import (C, inflateBack, "inflateBack"); + -- pragma Import (C, inflateBackEnd, "inflateBackEnd"); + +end ZLib.Thin; diff --git a/compat/zlib/contrib/ada/zlib.adb b/compat/zlib/contrib/ada/zlib.adb new file mode 100644 index 0000000..80acd9d --- /dev/null +++ b/compat/zlib/contrib/ada/zlib.adb @@ -0,0 +1,701 @@ +---------------------------------------------------------------- +-- 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 2008/12/19 14:44:49 dkf 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; diff --git a/compat/zlib/contrib/ada/zlib.ads b/compat/zlib/contrib/ada/zlib.ads new file mode 100644 index 0000000..5dfabc3 --- /dev/null +++ b/compat/zlib/contrib/ada/zlib.ads @@ -0,0 +1,328 @@ +------------------------------------------------------------------------------ +-- ZLib for Ada thick binding. -- +-- -- +-- Copyright (C) 2002-2004 Dmitriy Anisimkov -- +-- -- +-- This library is free software; you can redistribute it and/or modify -- +-- it under the terms of the GNU General Public License as published by -- +-- the Free Software Foundation; either version 2 of the License, or (at -- +-- your option) any later version. -- +-- -- +-- This library is distributed in the hope that it will be useful, but -- +-- WITHOUT ANY WARRANTY; without even the implied warranty of -- +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- +-- General Public License for more details. -- +-- -- +-- You should have received a copy of the GNU General Public License -- +-- along with this library; if not, write to the Free Software Foundation, -- +-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +------------------------------------------------------------------------------ + +-- $Id: zlib.ads,v 1.1 2008/12/19 14:44:49 dkf Exp $ + +with Ada.Streams; + +with Interfaces; + +package ZLib is + + ZLib_Error : exception; + Status_Error : exception; + + type Compression_Level is new Integer range -1 .. 9; + + type Flush_Mode is private; + + type Compression_Method is private; + + type Window_Bits_Type is new Integer range 8 .. 15; + + type Memory_Level_Type is new Integer range 1 .. 9; + + type Unsigned_32 is new Interfaces.Unsigned_32; + + type Strategy_Type is private; + + type Header_Type is (None, Auto, Default, GZip); + -- Header type usage have a some limitation for inflate. + -- See comment for Inflate_Init. + + subtype Count is Ada.Streams.Stream_Element_Count; + + Default_Memory_Level : constant Memory_Level_Type := 8; + Default_Window_Bits : constant Window_Bits_Type := 15; + + ---------------------------------- + -- Compression method constants -- + ---------------------------------- + + Deflated : constant Compression_Method; + -- Only one method allowed in this ZLib version + + --------------------------------- + -- Compression level constants -- + --------------------------------- + + No_Compression : constant Compression_Level := 0; + Best_Speed : constant Compression_Level := 1; + Best_Compression : constant Compression_Level := 9; + Default_Compression : constant Compression_Level := -1; + + -------------------------- + -- Flush mode constants -- + -------------------------- + + No_Flush : constant Flush_Mode; + -- Regular way for compression, no flush + + Partial_Flush : constant Flush_Mode; + -- Will be removed, use Z_SYNC_FLUSH instead + + Sync_Flush : constant Flush_Mode; + -- All pending output is flushed to the output buffer and the output + -- is aligned on a byte boundary, so that the decompressor can get all + -- input data available so far. (In particular avail_in is zero after the + -- call if enough output space has been provided before the call.) + -- Flushing may degrade compression for some compression algorithms and so + -- it should be used only when necessary. + + Block_Flush : constant Flush_Mode; + -- Z_BLOCK requests that inflate() stop + -- if and when it get to the next deflate block boundary. When decoding the + -- zlib or gzip format, this will cause inflate() to return immediately + -- after the header and before the first block. When doing a raw inflate, + -- inflate() will go ahead and process the first block, and will return + -- when it gets to the end of that block, or when it runs out of data. + + Full_Flush : constant Flush_Mode; + -- All output is flushed as with SYNC_FLUSH, and the compression state + -- is reset so that decompression can restart from this point if previous + -- compressed data has been damaged or if random access is desired. Using + -- Full_Flush too often can seriously degrade the compression. + + Finish : constant Flush_Mode; + -- Just for tell the compressor that input data is complete. + + ------------------------------------ + -- Compression strategy constants -- + ------------------------------------ + + -- RLE stategy could be used only in version 1.2.0 and later. + + Filtered : constant Strategy_Type; + Huffman_Only : constant Strategy_Type; + RLE : constant Strategy_Type; + Default_Strategy : constant Strategy_Type; + + Default_Buffer_Size : constant := 4096; + + type Filter_Type is tagged limited private; + -- The filter is for compression and for decompression. + -- The usage of the type is depend of its initialization. + + function Version return String; + pragma Inline (Version); + -- Return string representation of the ZLib version. + + 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); + -- Compressor initialization. + -- When Header parameter is Auto or Default, then default zlib header + -- would be provided for compressed data. + -- When Header is GZip, then gzip header would be set instead of + -- default header. + -- When Header is None, no header would be set for compressed data. + + procedure Inflate_Init + (Filter : in out Filter_Type; + Window_Bits : in Window_Bits_Type := Default_Window_Bits; + Header : in Header_Type := Default); + -- Decompressor initialization. + -- Default header type mean that ZLib default header is expecting in the + -- input compressed stream. + -- Header type None mean that no header is expecting in the input stream. + -- GZip header type mean that GZip header is expecting in the + -- input compressed stream. + -- Auto header type mean that header type (GZip or Native) would be + -- detected automatically in the input stream. + -- Note that header types parameter values None, GZip and Auto are + -- supported for inflate routine only in ZLib versions 1.2.0.2 and later. + -- Deflate_Init is supporting all header types. + + function Is_Open (Filter : in Filter_Type) return Boolean; + pragma Inline (Is_Open); + -- Is the filter opened for compression or decompression. + + procedure Close + (Filter : in out Filter_Type; + Ignore_Error : in Boolean := False); + -- Closing the compression or decompressor. + -- If stream is closing before the complete and Ignore_Error is False, + -- The exception would be raised. + + generic + with procedure Data_In + (Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + with procedure Data_Out + (Item : in Ada.Streams.Stream_Element_Array); + procedure Generic_Translate + (Filter : in out Filter_Type; + In_Buffer_Size : in Integer := Default_Buffer_Size; + Out_Buffer_Size : in Integer := Default_Buffer_Size); + -- Compress/decompress data fetch from Data_In routine and pass the result + -- to the Data_Out routine. User should provide Data_In and Data_Out + -- for compression/decompression data flow. + -- Compression or decompression depend on Filter initialization. + + function Total_In (Filter : in Filter_Type) return Count; + pragma Inline (Total_In); + -- Returns total number of input bytes read so far + + function Total_Out (Filter : in Filter_Type) return Count; + pragma Inline (Total_Out); + -- Returns total number of bytes output so far + + function CRC32 + (CRC : in Unsigned_32; + Data : in Ada.Streams.Stream_Element_Array) + return Unsigned_32; + pragma Inline (CRC32); + -- Compute CRC32, it could be necessary for make gzip format + + procedure CRC32 + (CRC : in out Unsigned_32; + Data : in Ada.Streams.Stream_Element_Array); + pragma Inline (CRC32); + -- Compute CRC32, it could be necessary for make gzip format + + ------------------------------------------------- + -- Below is more complex low level routines. -- + ------------------------------------------------- + + 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); + -- Compress/decompress the In_Data buffer and place the result into + -- Out_Data. In_Last is the index of last element from In_Data accepted by + -- the Filter. Out_Last is the last element of the received data from + -- Filter. To tell the filter that incoming data are complete put the + -- Flush parameter to Finish. + + function Stream_End (Filter : in Filter_Type) return Boolean; + pragma Inline (Stream_End); + -- Return the true when the stream is complete. + + 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); + pragma Inline (Flush); + -- Flushing the data from the compressor. + + generic + with procedure Write + (Item : in Ada.Streams.Stream_Element_Array); + -- User should provide this routine for accept + -- compressed/decompressed data. + + Buffer_Size : in Ada.Streams.Stream_Element_Offset + := Default_Buffer_Size; + -- Buffer size for Write user routine. + + procedure Write + (Filter : in out Filter_Type; + Item : in Ada.Streams.Stream_Element_Array; + Flush : in Flush_Mode := No_Flush); + -- Compress/Decompress data from Item to the generic parameter procedure + -- Write. Output buffer size could be set in Buffer_Size generic parameter. + + generic + with procedure Read + (Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- User should provide data for compression/decompression + -- thru this routine. + + Buffer : in out Ada.Streams.Stream_Element_Array; + -- Buffer for keep remaining data from the previous + -- back read. + + Rest_First, Rest_Last : in out Ada.Streams.Stream_Element_Offset; + -- Rest_First have to be initialized to Buffer'Last + 1 + -- Rest_Last have to be initialized to Buffer'Last + -- before usage. + + Allow_Read_Some : in Boolean := False; + -- Is it allowed to return Last < Item'Last before end of data. + + 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); + -- Compress/Decompress data from generic parameter procedure Read to the + -- Item. User should provide Buffer and initialized Rest_First, Rest_Last + -- indicators. If Allow_Read_Some is True, Read routines could return + -- Last < Item'Last only at end of stream. + +private + + use Ada.Streams; + + pragma Assert (Ada.Streams.Stream_Element'Size = 8); + pragma Assert (Ada.Streams.Stream_Element'Modulus = 2**8); + + type Flush_Mode is new Integer range 0 .. 5; + + type Compression_Method is new Integer range 8 .. 8; + + type Strategy_Type is new Integer range 0 .. 3; + + No_Flush : constant Flush_Mode := 0; + Partial_Flush : constant Flush_Mode := 1; + Sync_Flush : constant Flush_Mode := 2; + Full_Flush : constant Flush_Mode := 3; + Finish : constant Flush_Mode := 4; + Block_Flush : constant Flush_Mode := 5; + + Filtered : constant Strategy_Type := 1; + Huffman_Only : constant Strategy_Type := 2; + RLE : constant Strategy_Type := 3; + Default_Strategy : constant Strategy_Type := 0; + + Deflated : constant Compression_Method := 8; + + type Z_Stream; + + type Z_Stream_Access is access all Z_Stream; + + type Filter_Type is tagged limited record + Strm : Z_Stream_Access; + Compression : Boolean; + Stream_End : Boolean; + Header : Header_Type; + CRC : Unsigned_32; + Offset : Stream_Element_Offset; + -- Offset for gzip header/footer output. + end record; + +end ZLib; diff --git a/compat/zlib/contrib/ada/zlib.gpr b/compat/zlib/contrib/ada/zlib.gpr new file mode 100644 index 0000000..296b22a --- /dev/null +++ b/compat/zlib/contrib/ada/zlib.gpr @@ -0,0 +1,20 @@ +project Zlib is + + for Languages use ("Ada"); + for Source_Dirs use ("."); + for Object_Dir use "."; + for Main use ("test.adb", "mtest.adb", "read.adb", "buffer_demo"); + + package Compiler is + for Default_Switches ("ada") use ("-gnatwcfilopru", "-gnatVcdfimorst", "-gnatyabcefhiklmnoprst"); + end Compiler; + + package Linker is + for Default_Switches ("ada") use ("-lz"); + end Linker; + + package Builder is + for Default_Switches ("ada") use ("-s", "-gnatQ"); + end Builder; + +end Zlib; |