1aaf4ece6Schristos---------------------------------------------------------------- 2aaf4ece6Schristos-- ZLib for Ada thick binding. -- 3aaf4ece6Schristos-- -- 4aaf4ece6Schristos-- Copyright (C) 2002-2004 Dmitriy Anisimkov -- 5aaf4ece6Schristos-- -- 6aaf4ece6Schristos-- Open source license information is in the zlib.ads file. -- 7aaf4ece6Schristos---------------------------------------------------------------- 8aaf4ece6Schristos 9dbdd0313Schristos-- Id: zlib.adb,v 1.31 2004/09/06 06:53:19 vagul Exp 10aaf4ece6Schristos 11aaf4ece6Schristoswith Ada.Exceptions; 12aaf4ece6Schristoswith Ada.Unchecked_Conversion; 13aaf4ece6Schristoswith Ada.Unchecked_Deallocation; 14aaf4ece6Schristos 15aaf4ece6Schristoswith Interfaces.C.Strings; 16aaf4ece6Schristos 17aaf4ece6Schristoswith ZLib.Thin; 18aaf4ece6Schristos 19aaf4ece6Schristospackage body ZLib is 20aaf4ece6Schristos 21aaf4ece6Schristos use type Thin.Int; 22aaf4ece6Schristos 23aaf4ece6Schristos type Z_Stream is new Thin.Z_Stream; 24aaf4ece6Schristos 25aaf4ece6Schristos type Return_Code_Enum is 26aaf4ece6Schristos (OK, 27aaf4ece6Schristos STREAM_END, 28aaf4ece6Schristos NEED_DICT, 29aaf4ece6Schristos ERRNO, 30aaf4ece6Schristos STREAM_ERROR, 31aaf4ece6Schristos DATA_ERROR, 32aaf4ece6Schristos MEM_ERROR, 33aaf4ece6Schristos BUF_ERROR, 34aaf4ece6Schristos VERSION_ERROR); 35aaf4ece6Schristos 36aaf4ece6Schristos type Flate_Step_Function is access 37aaf4ece6Schristos function (Strm : in Thin.Z_Streamp; Flush : in Thin.Int) return Thin.Int; 38aaf4ece6Schristos pragma Convention (C, Flate_Step_Function); 39aaf4ece6Schristos 40aaf4ece6Schristos type Flate_End_Function is access 41aaf4ece6Schristos function (Ctrm : in Thin.Z_Streamp) return Thin.Int; 42aaf4ece6Schristos pragma Convention (C, Flate_End_Function); 43aaf4ece6Schristos 44aaf4ece6Schristos type Flate_Type is record 45aaf4ece6Schristos Step : Flate_Step_Function; 46aaf4ece6Schristos Done : Flate_End_Function; 47aaf4ece6Schristos end record; 48aaf4ece6Schristos 49aaf4ece6Schristos subtype Footer_Array is Stream_Element_Array (1 .. 8); 50aaf4ece6Schristos 51aaf4ece6Schristos Simple_GZip_Header : constant Stream_Element_Array (1 .. 10) 52aaf4ece6Schristos := (16#1f#, 16#8b#, -- Magic header 53aaf4ece6Schristos 16#08#, -- Z_DEFLATED 54aaf4ece6Schristos 16#00#, -- Flags 55aaf4ece6Schristos 16#00#, 16#00#, 16#00#, 16#00#, -- Time 56aaf4ece6Schristos 16#00#, -- XFlags 57aaf4ece6Schristos 16#03# -- OS code 58aaf4ece6Schristos ); 59aaf4ece6Schristos -- The simplest gzip header is not for informational, but just for 60aaf4ece6Schristos -- gzip format compatibility. 61aaf4ece6Schristos -- Note that some code below is using assumption 62aaf4ece6Schristos -- Simple_GZip_Header'Last > Footer_Array'Last, so do not make 63aaf4ece6Schristos -- Simple_GZip_Header'Last <= Footer_Array'Last. 64aaf4ece6Schristos 65aaf4ece6Schristos Return_Code : constant array (Thin.Int range <>) of Return_Code_Enum 66aaf4ece6Schristos := (0 => OK, 67aaf4ece6Schristos 1 => STREAM_END, 68aaf4ece6Schristos 2 => NEED_DICT, 69aaf4ece6Schristos -1 => ERRNO, 70aaf4ece6Schristos -2 => STREAM_ERROR, 71aaf4ece6Schristos -3 => DATA_ERROR, 72aaf4ece6Schristos -4 => MEM_ERROR, 73aaf4ece6Schristos -5 => BUF_ERROR, 74aaf4ece6Schristos -6 => VERSION_ERROR); 75aaf4ece6Schristos 76aaf4ece6Schristos Flate : constant array (Boolean) of Flate_Type 77aaf4ece6Schristos := (True => (Step => Thin.Deflate'Access, 78aaf4ece6Schristos Done => Thin.DeflateEnd'Access), 79aaf4ece6Schristos False => (Step => Thin.Inflate'Access, 80aaf4ece6Schristos Done => Thin.InflateEnd'Access)); 81aaf4ece6Schristos 82aaf4ece6Schristos Flush_Finish : constant array (Boolean) of Flush_Mode 83aaf4ece6Schristos := (True => Finish, False => No_Flush); 84aaf4ece6Schristos 85aaf4ece6Schristos procedure Raise_Error (Stream : in Z_Stream); 86aaf4ece6Schristos pragma Inline (Raise_Error); 87aaf4ece6Schristos 88aaf4ece6Schristos procedure Raise_Error (Message : in String); 89aaf4ece6Schristos pragma Inline (Raise_Error); 90aaf4ece6Schristos 91aaf4ece6Schristos procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int); 92aaf4ece6Schristos 93aaf4ece6Schristos procedure Free is new Ada.Unchecked_Deallocation 94aaf4ece6Schristos (Z_Stream, Z_Stream_Access); 95aaf4ece6Schristos 96aaf4ece6Schristos function To_Thin_Access is new Ada.Unchecked_Conversion 97aaf4ece6Schristos (Z_Stream_Access, Thin.Z_Streamp); 98aaf4ece6Schristos 99aaf4ece6Schristos procedure Translate_GZip 100aaf4ece6Schristos (Filter : in out Filter_Type; 101aaf4ece6Schristos In_Data : in Ada.Streams.Stream_Element_Array; 102aaf4ece6Schristos In_Last : out Ada.Streams.Stream_Element_Offset; 103aaf4ece6Schristos Out_Data : out Ada.Streams.Stream_Element_Array; 104aaf4ece6Schristos Out_Last : out Ada.Streams.Stream_Element_Offset; 105aaf4ece6Schristos Flush : in Flush_Mode); 106aaf4ece6Schristos -- Separate translate routine for make gzip header. 107aaf4ece6Schristos 108aaf4ece6Schristos procedure Translate_Auto 109aaf4ece6Schristos (Filter : in out Filter_Type; 110aaf4ece6Schristos In_Data : in Ada.Streams.Stream_Element_Array; 111aaf4ece6Schristos In_Last : out Ada.Streams.Stream_Element_Offset; 112aaf4ece6Schristos Out_Data : out Ada.Streams.Stream_Element_Array; 113aaf4ece6Schristos Out_Last : out Ada.Streams.Stream_Element_Offset; 114aaf4ece6Schristos Flush : in Flush_Mode); 115aaf4ece6Schristos -- translate routine without additional headers. 116aaf4ece6Schristos 117aaf4ece6Schristos ----------------- 118aaf4ece6Schristos -- Check_Error -- 119aaf4ece6Schristos ----------------- 120aaf4ece6Schristos 121aaf4ece6Schristos procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int) is 122aaf4ece6Schristos use type Thin.Int; 123aaf4ece6Schristos begin 124aaf4ece6Schristos if Code /= Thin.Z_OK then 125aaf4ece6Schristos Raise_Error 126aaf4ece6Schristos (Return_Code_Enum'Image (Return_Code (Code)) 127aaf4ece6Schristos & ": " & Last_Error_Message (Stream)); 128aaf4ece6Schristos end if; 129aaf4ece6Schristos end Check_Error; 130aaf4ece6Schristos 131aaf4ece6Schristos ----------- 132aaf4ece6Schristos -- Close -- 133aaf4ece6Schristos ----------- 134aaf4ece6Schristos 135aaf4ece6Schristos procedure Close 136aaf4ece6Schristos (Filter : in out Filter_Type; 137aaf4ece6Schristos Ignore_Error : in Boolean := False) 138aaf4ece6Schristos is 139aaf4ece6Schristos Code : Thin.Int; 140aaf4ece6Schristos begin 141aaf4ece6Schristos if not Ignore_Error and then not Is_Open (Filter) then 142aaf4ece6Schristos raise Status_Error; 143aaf4ece6Schristos end if; 144aaf4ece6Schristos 145aaf4ece6Schristos Code := Flate (Filter.Compression).Done (To_Thin_Access (Filter.Strm)); 146aaf4ece6Schristos 147aaf4ece6Schristos if Ignore_Error or else Code = Thin.Z_OK then 148aaf4ece6Schristos Free (Filter.Strm); 149aaf4ece6Schristos else 150aaf4ece6Schristos declare 151aaf4ece6Schristos Error_Message : constant String 152aaf4ece6Schristos := Last_Error_Message (Filter.Strm.all); 153aaf4ece6Schristos begin 154aaf4ece6Schristos Free (Filter.Strm); 155aaf4ece6Schristos Ada.Exceptions.Raise_Exception 156aaf4ece6Schristos (ZLib_Error'Identity, 157aaf4ece6Schristos Return_Code_Enum'Image (Return_Code (Code)) 158aaf4ece6Schristos & ": " & Error_Message); 159aaf4ece6Schristos end; 160aaf4ece6Schristos end if; 161aaf4ece6Schristos end Close; 162aaf4ece6Schristos 163aaf4ece6Schristos ----------- 164aaf4ece6Schristos -- CRC32 -- 165aaf4ece6Schristos ----------- 166aaf4ece6Schristos 167aaf4ece6Schristos function CRC32 168aaf4ece6Schristos (CRC : in Unsigned_32; 169aaf4ece6Schristos Data : in Ada.Streams.Stream_Element_Array) 170aaf4ece6Schristos return Unsigned_32 171aaf4ece6Schristos is 172aaf4ece6Schristos use Thin; 173aaf4ece6Schristos begin 174aaf4ece6Schristos return Unsigned_32 (crc32 (ULong (CRC), 175aaf4ece6Schristos Data'Address, 176aaf4ece6Schristos Data'Length)); 177aaf4ece6Schristos end CRC32; 178aaf4ece6Schristos 179aaf4ece6Schristos procedure CRC32 180aaf4ece6Schristos (CRC : in out Unsigned_32; 181aaf4ece6Schristos Data : in Ada.Streams.Stream_Element_Array) is 182aaf4ece6Schristos begin 183aaf4ece6Schristos CRC := CRC32 (CRC, Data); 184aaf4ece6Schristos end CRC32; 185aaf4ece6Schristos 186aaf4ece6Schristos ------------------ 187aaf4ece6Schristos -- Deflate_Init -- 188aaf4ece6Schristos ------------------ 189aaf4ece6Schristos 190aaf4ece6Schristos procedure Deflate_Init 191aaf4ece6Schristos (Filter : in out Filter_Type; 192aaf4ece6Schristos Level : in Compression_Level := Default_Compression; 193aaf4ece6Schristos Strategy : in Strategy_Type := Default_Strategy; 194aaf4ece6Schristos Method : in Compression_Method := Deflated; 195aaf4ece6Schristos Window_Bits : in Window_Bits_Type := Default_Window_Bits; 196aaf4ece6Schristos Memory_Level : in Memory_Level_Type := Default_Memory_Level; 197aaf4ece6Schristos Header : in Header_Type := Default) 198aaf4ece6Schristos is 199aaf4ece6Schristos use type Thin.Int; 200aaf4ece6Schristos Win_Bits : Thin.Int := Thin.Int (Window_Bits); 201aaf4ece6Schristos begin 202aaf4ece6Schristos if Is_Open (Filter) then 203aaf4ece6Schristos raise Status_Error; 204aaf4ece6Schristos end if; 205aaf4ece6Schristos 206aaf4ece6Schristos -- We allow ZLib to make header only in case of default header type. 207*b175d1c2Schristos -- Otherwise we would either do header by ourselves, or do not do 208aaf4ece6Schristos -- header at all. 209aaf4ece6Schristos 210aaf4ece6Schristos if Header = None or else Header = GZip then 211aaf4ece6Schristos Win_Bits := -Win_Bits; 212aaf4ece6Schristos end if; 213aaf4ece6Schristos 214aaf4ece6Schristos -- For the GZip CRC calculation and make headers. 215aaf4ece6Schristos 216aaf4ece6Schristos if Header = GZip then 217aaf4ece6Schristos Filter.CRC := 0; 218aaf4ece6Schristos Filter.Offset := Simple_GZip_Header'First; 219aaf4ece6Schristos else 220aaf4ece6Schristos Filter.Offset := Simple_GZip_Header'Last + 1; 221aaf4ece6Schristos end if; 222aaf4ece6Schristos 223aaf4ece6Schristos Filter.Strm := new Z_Stream; 224aaf4ece6Schristos Filter.Compression := True; 225aaf4ece6Schristos Filter.Stream_End := False; 226aaf4ece6Schristos Filter.Header := Header; 227aaf4ece6Schristos 228aaf4ece6Schristos if Thin.Deflate_Init 229aaf4ece6Schristos (To_Thin_Access (Filter.Strm), 230aaf4ece6Schristos Level => Thin.Int (Level), 231aaf4ece6Schristos method => Thin.Int (Method), 232aaf4ece6Schristos windowBits => Win_Bits, 233aaf4ece6Schristos memLevel => Thin.Int (Memory_Level), 234aaf4ece6Schristos strategy => Thin.Int (Strategy)) /= Thin.Z_OK 235aaf4ece6Schristos then 236aaf4ece6Schristos Raise_Error (Filter.Strm.all); 237aaf4ece6Schristos end if; 238aaf4ece6Schristos end Deflate_Init; 239aaf4ece6Schristos 240aaf4ece6Schristos ----------- 241aaf4ece6Schristos -- Flush -- 242aaf4ece6Schristos ----------- 243aaf4ece6Schristos 244aaf4ece6Schristos procedure Flush 245aaf4ece6Schristos (Filter : in out Filter_Type; 246aaf4ece6Schristos Out_Data : out Ada.Streams.Stream_Element_Array; 247aaf4ece6Schristos Out_Last : out Ada.Streams.Stream_Element_Offset; 248aaf4ece6Schristos Flush : in Flush_Mode) 249aaf4ece6Schristos is 250aaf4ece6Schristos No_Data : Stream_Element_Array := (1 .. 0 => 0); 251aaf4ece6Schristos Last : Stream_Element_Offset; 252aaf4ece6Schristos begin 253aaf4ece6Schristos Translate (Filter, No_Data, Last, Out_Data, Out_Last, Flush); 254aaf4ece6Schristos end Flush; 255aaf4ece6Schristos 256aaf4ece6Schristos ----------------------- 257aaf4ece6Schristos -- Generic_Translate -- 258aaf4ece6Schristos ----------------------- 259aaf4ece6Schristos 260aaf4ece6Schristos procedure Generic_Translate 261aaf4ece6Schristos (Filter : in out ZLib.Filter_Type; 262aaf4ece6Schristos In_Buffer_Size : in Integer := Default_Buffer_Size; 263aaf4ece6Schristos Out_Buffer_Size : in Integer := Default_Buffer_Size) 264aaf4ece6Schristos is 265aaf4ece6Schristos In_Buffer : Stream_Element_Array 266aaf4ece6Schristos (1 .. Stream_Element_Offset (In_Buffer_Size)); 267aaf4ece6Schristos Out_Buffer : Stream_Element_Array 268aaf4ece6Schristos (1 .. Stream_Element_Offset (Out_Buffer_Size)); 269aaf4ece6Schristos Last : Stream_Element_Offset; 270aaf4ece6Schristos In_Last : Stream_Element_Offset; 271aaf4ece6Schristos In_First : Stream_Element_Offset; 272aaf4ece6Schristos Out_Last : Stream_Element_Offset; 273aaf4ece6Schristos begin 274aaf4ece6Schristos Main : loop 275aaf4ece6Schristos Data_In (In_Buffer, Last); 276aaf4ece6Schristos 277aaf4ece6Schristos In_First := In_Buffer'First; 278aaf4ece6Schristos 279aaf4ece6Schristos loop 280aaf4ece6Schristos Translate 281aaf4ece6Schristos (Filter => Filter, 282aaf4ece6Schristos In_Data => In_Buffer (In_First .. Last), 283aaf4ece6Schristos In_Last => In_Last, 284aaf4ece6Schristos Out_Data => Out_Buffer, 285aaf4ece6Schristos Out_Last => Out_Last, 286aaf4ece6Schristos Flush => Flush_Finish (Last < In_Buffer'First)); 287aaf4ece6Schristos 288aaf4ece6Schristos if Out_Buffer'First <= Out_Last then 289aaf4ece6Schristos Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last)); 290aaf4ece6Schristos end if; 291aaf4ece6Schristos 292aaf4ece6Schristos exit Main when Stream_End (Filter); 293aaf4ece6Schristos 294aaf4ece6Schristos -- The end of in buffer. 295aaf4ece6Schristos 296aaf4ece6Schristos exit when In_Last = Last; 297aaf4ece6Schristos 298aaf4ece6Schristos In_First := In_Last + 1; 299aaf4ece6Schristos end loop; 300aaf4ece6Schristos end loop Main; 301aaf4ece6Schristos 302aaf4ece6Schristos end Generic_Translate; 303aaf4ece6Schristos 304aaf4ece6Schristos ------------------ 305aaf4ece6Schristos -- Inflate_Init -- 306aaf4ece6Schristos ------------------ 307aaf4ece6Schristos 308aaf4ece6Schristos procedure Inflate_Init 309aaf4ece6Schristos (Filter : in out Filter_Type; 310aaf4ece6Schristos Window_Bits : in Window_Bits_Type := Default_Window_Bits; 311aaf4ece6Schristos Header : in Header_Type := Default) 312aaf4ece6Schristos is 313aaf4ece6Schristos use type Thin.Int; 314aaf4ece6Schristos Win_Bits : Thin.Int := Thin.Int (Window_Bits); 315aaf4ece6Schristos 316aaf4ece6Schristos procedure Check_Version; 317aaf4ece6Schristos -- Check the latest header types compatibility. 318aaf4ece6Schristos 319aaf4ece6Schristos procedure Check_Version is 320aaf4ece6Schristos begin 321aaf4ece6Schristos if Version <= "1.1.4" then 322aaf4ece6Schristos Raise_Error 323aaf4ece6Schristos ("Inflate header type " & Header_Type'Image (Header) 324aaf4ece6Schristos & " incompatible with ZLib version " & Version); 325aaf4ece6Schristos end if; 326aaf4ece6Schristos end Check_Version; 327aaf4ece6Schristos 328aaf4ece6Schristos begin 329aaf4ece6Schristos if Is_Open (Filter) then 330aaf4ece6Schristos raise Status_Error; 331aaf4ece6Schristos end if; 332aaf4ece6Schristos 333aaf4ece6Schristos case Header is 334aaf4ece6Schristos when None => 335aaf4ece6Schristos Check_Version; 336aaf4ece6Schristos 337aaf4ece6Schristos -- Inflate data without headers determined 338aaf4ece6Schristos -- by negative Win_Bits. 339aaf4ece6Schristos 340aaf4ece6Schristos Win_Bits := -Win_Bits; 341aaf4ece6Schristos when GZip => 342aaf4ece6Schristos Check_Version; 343aaf4ece6Schristos 344aaf4ece6Schristos -- Inflate gzip data defined by flag 16. 345aaf4ece6Schristos 346aaf4ece6Schristos Win_Bits := Win_Bits + 16; 347aaf4ece6Schristos when Auto => 348aaf4ece6Schristos Check_Version; 349aaf4ece6Schristos 350aaf4ece6Schristos -- Inflate with automatic detection 351aaf4ece6Schristos -- of gzip or native header defined by flag 32. 352aaf4ece6Schristos 353aaf4ece6Schristos Win_Bits := Win_Bits + 32; 354aaf4ece6Schristos when Default => null; 355aaf4ece6Schristos end case; 356aaf4ece6Schristos 357aaf4ece6Schristos Filter.Strm := new Z_Stream; 358aaf4ece6Schristos Filter.Compression := False; 359aaf4ece6Schristos Filter.Stream_End := False; 360aaf4ece6Schristos Filter.Header := Header; 361aaf4ece6Schristos 362aaf4ece6Schristos if Thin.Inflate_Init 363aaf4ece6Schristos (To_Thin_Access (Filter.Strm), Win_Bits) /= Thin.Z_OK 364aaf4ece6Schristos then 365aaf4ece6Schristos Raise_Error (Filter.Strm.all); 366aaf4ece6Schristos end if; 367aaf4ece6Schristos end Inflate_Init; 368aaf4ece6Schristos 369aaf4ece6Schristos ------------- 370aaf4ece6Schristos -- Is_Open -- 371aaf4ece6Schristos ------------- 372aaf4ece6Schristos 373aaf4ece6Schristos function Is_Open (Filter : in Filter_Type) return Boolean is 374aaf4ece6Schristos begin 375aaf4ece6Schristos return Filter.Strm /= null; 376aaf4ece6Schristos end Is_Open; 377aaf4ece6Schristos 378aaf4ece6Schristos ----------------- 379aaf4ece6Schristos -- Raise_Error -- 380aaf4ece6Schristos ----------------- 381aaf4ece6Schristos 382aaf4ece6Schristos procedure Raise_Error (Message : in String) is 383aaf4ece6Schristos begin 384aaf4ece6Schristos Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message); 385aaf4ece6Schristos end Raise_Error; 386aaf4ece6Schristos 387aaf4ece6Schristos procedure Raise_Error (Stream : in Z_Stream) is 388aaf4ece6Schristos begin 389aaf4ece6Schristos Raise_Error (Last_Error_Message (Stream)); 390aaf4ece6Schristos end Raise_Error; 391aaf4ece6Schristos 392aaf4ece6Schristos ---------- 393aaf4ece6Schristos -- Read -- 394aaf4ece6Schristos ---------- 395aaf4ece6Schristos 396aaf4ece6Schristos procedure Read 397aaf4ece6Schristos (Filter : in out Filter_Type; 398aaf4ece6Schristos Item : out Ada.Streams.Stream_Element_Array; 399aaf4ece6Schristos Last : out Ada.Streams.Stream_Element_Offset; 400aaf4ece6Schristos Flush : in Flush_Mode := No_Flush) 401aaf4ece6Schristos is 402aaf4ece6Schristos In_Last : Stream_Element_Offset; 403aaf4ece6Schristos Item_First : Ada.Streams.Stream_Element_Offset := Item'First; 404aaf4ece6Schristos V_Flush : Flush_Mode := Flush; 405aaf4ece6Schristos 406aaf4ece6Schristos begin 407aaf4ece6Schristos pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1); 408aaf4ece6Schristos pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last); 409aaf4ece6Schristos 410aaf4ece6Schristos loop 411aaf4ece6Schristos if Rest_Last = Buffer'First - 1 then 412aaf4ece6Schristos V_Flush := Finish; 413aaf4ece6Schristos 414aaf4ece6Schristos elsif Rest_First > Rest_Last then 415aaf4ece6Schristos Read (Buffer, Rest_Last); 416aaf4ece6Schristos Rest_First := Buffer'First; 417aaf4ece6Schristos 418aaf4ece6Schristos if Rest_Last < Buffer'First then 419aaf4ece6Schristos V_Flush := Finish; 420aaf4ece6Schristos end if; 421aaf4ece6Schristos end if; 422aaf4ece6Schristos 423aaf4ece6Schristos Translate 424aaf4ece6Schristos (Filter => Filter, 425aaf4ece6Schristos In_Data => Buffer (Rest_First .. Rest_Last), 426aaf4ece6Schristos In_Last => In_Last, 427aaf4ece6Schristos Out_Data => Item (Item_First .. Item'Last), 428aaf4ece6Schristos Out_Last => Last, 429aaf4ece6Schristos Flush => V_Flush); 430aaf4ece6Schristos 431aaf4ece6Schristos Rest_First := In_Last + 1; 432aaf4ece6Schristos 433aaf4ece6Schristos exit when Stream_End (Filter) 434aaf4ece6Schristos or else Last = Item'Last 435aaf4ece6Schristos or else (Last >= Item'First and then Allow_Read_Some); 436aaf4ece6Schristos 437aaf4ece6Schristos Item_First := Last + 1; 438aaf4ece6Schristos end loop; 439aaf4ece6Schristos end Read; 440aaf4ece6Schristos 441aaf4ece6Schristos ---------------- 442aaf4ece6Schristos -- Stream_End -- 443aaf4ece6Schristos ---------------- 444aaf4ece6Schristos 445aaf4ece6Schristos function Stream_End (Filter : in Filter_Type) return Boolean is 446aaf4ece6Schristos begin 447aaf4ece6Schristos if Filter.Header = GZip and Filter.Compression then 448aaf4ece6Schristos return Filter.Stream_End 449aaf4ece6Schristos and then Filter.Offset = Footer_Array'Last + 1; 450aaf4ece6Schristos else 451aaf4ece6Schristos return Filter.Stream_End; 452aaf4ece6Schristos end if; 453aaf4ece6Schristos end Stream_End; 454aaf4ece6Schristos 455aaf4ece6Schristos -------------- 456aaf4ece6Schristos -- Total_In -- 457aaf4ece6Schristos -------------- 458aaf4ece6Schristos 459aaf4ece6Schristos function Total_In (Filter : in Filter_Type) return Count is 460aaf4ece6Schristos begin 461aaf4ece6Schristos return Count (Thin.Total_In (To_Thin_Access (Filter.Strm).all)); 462aaf4ece6Schristos end Total_In; 463aaf4ece6Schristos 464aaf4ece6Schristos --------------- 465aaf4ece6Schristos -- Total_Out -- 466aaf4ece6Schristos --------------- 467aaf4ece6Schristos 468aaf4ece6Schristos function Total_Out (Filter : in Filter_Type) return Count is 469aaf4ece6Schristos begin 470aaf4ece6Schristos return Count (Thin.Total_Out (To_Thin_Access (Filter.Strm).all)); 471aaf4ece6Schristos end Total_Out; 472aaf4ece6Schristos 473aaf4ece6Schristos --------------- 474aaf4ece6Schristos -- Translate -- 475aaf4ece6Schristos --------------- 476aaf4ece6Schristos 477aaf4ece6Schristos procedure Translate 478aaf4ece6Schristos (Filter : in out Filter_Type; 479aaf4ece6Schristos In_Data : in Ada.Streams.Stream_Element_Array; 480aaf4ece6Schristos In_Last : out Ada.Streams.Stream_Element_Offset; 481aaf4ece6Schristos Out_Data : out Ada.Streams.Stream_Element_Array; 482aaf4ece6Schristos Out_Last : out Ada.Streams.Stream_Element_Offset; 483aaf4ece6Schristos Flush : in Flush_Mode) is 484aaf4ece6Schristos begin 485aaf4ece6Schristos if Filter.Header = GZip and then Filter.Compression then 486aaf4ece6Schristos Translate_GZip 487aaf4ece6Schristos (Filter => Filter, 488aaf4ece6Schristos In_Data => In_Data, 489aaf4ece6Schristos In_Last => In_Last, 490aaf4ece6Schristos Out_Data => Out_Data, 491aaf4ece6Schristos Out_Last => Out_Last, 492aaf4ece6Schristos Flush => Flush); 493aaf4ece6Schristos else 494aaf4ece6Schristos Translate_Auto 495aaf4ece6Schristos (Filter => Filter, 496aaf4ece6Schristos In_Data => In_Data, 497aaf4ece6Schristos In_Last => In_Last, 498aaf4ece6Schristos Out_Data => Out_Data, 499aaf4ece6Schristos Out_Last => Out_Last, 500aaf4ece6Schristos Flush => Flush); 501aaf4ece6Schristos end if; 502aaf4ece6Schristos end Translate; 503aaf4ece6Schristos 504aaf4ece6Schristos -------------------- 505aaf4ece6Schristos -- Translate_Auto -- 506aaf4ece6Schristos -------------------- 507aaf4ece6Schristos 508aaf4ece6Schristos procedure Translate_Auto 509aaf4ece6Schristos (Filter : in out Filter_Type; 510aaf4ece6Schristos In_Data : in Ada.Streams.Stream_Element_Array; 511aaf4ece6Schristos In_Last : out Ada.Streams.Stream_Element_Offset; 512aaf4ece6Schristos Out_Data : out Ada.Streams.Stream_Element_Array; 513aaf4ece6Schristos Out_Last : out Ada.Streams.Stream_Element_Offset; 514aaf4ece6Schristos Flush : in Flush_Mode) 515aaf4ece6Schristos is 516aaf4ece6Schristos use type Thin.Int; 517aaf4ece6Schristos Code : Thin.Int; 518aaf4ece6Schristos 519aaf4ece6Schristos begin 520aaf4ece6Schristos if not Is_Open (Filter) then 521aaf4ece6Schristos raise Status_Error; 522aaf4ece6Schristos end if; 523aaf4ece6Schristos 524aaf4ece6Schristos if Out_Data'Length = 0 and then In_Data'Length = 0 then 525aaf4ece6Schristos raise Constraint_Error; 526aaf4ece6Schristos end if; 527aaf4ece6Schristos 528aaf4ece6Schristos Set_Out (Filter.Strm.all, Out_Data'Address, Out_Data'Length); 529aaf4ece6Schristos Set_In (Filter.Strm.all, In_Data'Address, In_Data'Length); 530aaf4ece6Schristos 531aaf4ece6Schristos Code := Flate (Filter.Compression).Step 532aaf4ece6Schristos (To_Thin_Access (Filter.Strm), 533aaf4ece6Schristos Thin.Int (Flush)); 534aaf4ece6Schristos 535aaf4ece6Schristos if Code = Thin.Z_STREAM_END then 536aaf4ece6Schristos Filter.Stream_End := True; 537aaf4ece6Schristos else 538aaf4ece6Schristos Check_Error (Filter.Strm.all, Code); 539aaf4ece6Schristos end if; 540aaf4ece6Schristos 541aaf4ece6Schristos In_Last := In_Data'Last 542aaf4ece6Schristos - Stream_Element_Offset (Avail_In (Filter.Strm.all)); 543aaf4ece6Schristos Out_Last := Out_Data'Last 544aaf4ece6Schristos - Stream_Element_Offset (Avail_Out (Filter.Strm.all)); 545aaf4ece6Schristos end Translate_Auto; 546aaf4ece6Schristos 547aaf4ece6Schristos -------------------- 548aaf4ece6Schristos -- Translate_GZip -- 549aaf4ece6Schristos -------------------- 550aaf4ece6Schristos 551aaf4ece6Schristos procedure Translate_GZip 552aaf4ece6Schristos (Filter : in out Filter_Type; 553aaf4ece6Schristos In_Data : in Ada.Streams.Stream_Element_Array; 554aaf4ece6Schristos In_Last : out Ada.Streams.Stream_Element_Offset; 555aaf4ece6Schristos Out_Data : out Ada.Streams.Stream_Element_Array; 556aaf4ece6Schristos Out_Last : out Ada.Streams.Stream_Element_Offset; 557aaf4ece6Schristos Flush : in Flush_Mode) 558aaf4ece6Schristos is 559aaf4ece6Schristos Out_First : Stream_Element_Offset; 560aaf4ece6Schristos 561aaf4ece6Schristos procedure Add_Data (Data : in Stream_Element_Array); 562aaf4ece6Schristos -- Add data to stream from the Filter.Offset till necessary, 563aaf4ece6Schristos -- used for add gzip headr/footer. 564aaf4ece6Schristos 565aaf4ece6Schristos procedure Put_32 566aaf4ece6Schristos (Item : in out Stream_Element_Array; 567aaf4ece6Schristos Data : in Unsigned_32); 568aaf4ece6Schristos pragma Inline (Put_32); 569aaf4ece6Schristos 570aaf4ece6Schristos -------------- 571aaf4ece6Schristos -- Add_Data -- 572aaf4ece6Schristos -------------- 573aaf4ece6Schristos 574aaf4ece6Schristos procedure Add_Data (Data : in Stream_Element_Array) is 575aaf4ece6Schristos Data_First : Stream_Element_Offset renames Filter.Offset; 576aaf4ece6Schristos Data_Last : Stream_Element_Offset; 577aaf4ece6Schristos Data_Len : Stream_Element_Offset; -- -1 578aaf4ece6Schristos Out_Len : Stream_Element_Offset; -- -1 579aaf4ece6Schristos begin 580aaf4ece6Schristos Out_First := Out_Last + 1; 581aaf4ece6Schristos 582aaf4ece6Schristos if Data_First > Data'Last then 583aaf4ece6Schristos return; 584aaf4ece6Schristos end if; 585aaf4ece6Schristos 586aaf4ece6Schristos Data_Len := Data'Last - Data_First; 587aaf4ece6Schristos Out_Len := Out_Data'Last - Out_First; 588aaf4ece6Schristos 589aaf4ece6Schristos if Data_Len <= Out_Len then 590aaf4ece6Schristos Out_Last := Out_First + Data_Len; 591aaf4ece6Schristos Data_Last := Data'Last; 592aaf4ece6Schristos else 593aaf4ece6Schristos Out_Last := Out_Data'Last; 594aaf4ece6Schristos Data_Last := Data_First + Out_Len; 595aaf4ece6Schristos end if; 596aaf4ece6Schristos 597aaf4ece6Schristos Out_Data (Out_First .. Out_Last) := Data (Data_First .. Data_Last); 598aaf4ece6Schristos 599aaf4ece6Schristos Data_First := Data_Last + 1; 600aaf4ece6Schristos Out_First := Out_Last + 1; 601aaf4ece6Schristos end Add_Data; 602aaf4ece6Schristos 603aaf4ece6Schristos ------------ 604aaf4ece6Schristos -- Put_32 -- 605aaf4ece6Schristos ------------ 606aaf4ece6Schristos 607aaf4ece6Schristos procedure Put_32 608aaf4ece6Schristos (Item : in out Stream_Element_Array; 609aaf4ece6Schristos Data : in Unsigned_32) 610aaf4ece6Schristos is 611aaf4ece6Schristos D : Unsigned_32 := Data; 612aaf4ece6Schristos begin 613aaf4ece6Schristos for J in Item'First .. Item'First + 3 loop 614aaf4ece6Schristos Item (J) := Stream_Element (D and 16#FF#); 615aaf4ece6Schristos D := Shift_Right (D, 8); 616aaf4ece6Schristos end loop; 617aaf4ece6Schristos end Put_32; 618aaf4ece6Schristos 619aaf4ece6Schristos begin 620aaf4ece6Schristos Out_Last := Out_Data'First - 1; 621aaf4ece6Schristos 622aaf4ece6Schristos if not Filter.Stream_End then 623aaf4ece6Schristos Add_Data (Simple_GZip_Header); 624aaf4ece6Schristos 625aaf4ece6Schristos Translate_Auto 626aaf4ece6Schristos (Filter => Filter, 627aaf4ece6Schristos In_Data => In_Data, 628aaf4ece6Schristos In_Last => In_Last, 629aaf4ece6Schristos Out_Data => Out_Data (Out_First .. Out_Data'Last), 630aaf4ece6Schristos Out_Last => Out_Last, 631aaf4ece6Schristos Flush => Flush); 632aaf4ece6Schristos 633aaf4ece6Schristos CRC32 (Filter.CRC, In_Data (In_Data'First .. In_Last)); 634aaf4ece6Schristos end if; 635aaf4ece6Schristos 636aaf4ece6Schristos if Filter.Stream_End and then Out_Last <= Out_Data'Last then 637aaf4ece6Schristos -- This detection method would work only when 638aaf4ece6Schristos -- Simple_GZip_Header'Last > Footer_Array'Last 639aaf4ece6Schristos 640aaf4ece6Schristos if Filter.Offset = Simple_GZip_Header'Last + 1 then 641aaf4ece6Schristos Filter.Offset := Footer_Array'First; 642aaf4ece6Schristos end if; 643aaf4ece6Schristos 644aaf4ece6Schristos declare 645aaf4ece6Schristos Footer : Footer_Array; 646aaf4ece6Schristos begin 647aaf4ece6Schristos Put_32 (Footer, Filter.CRC); 648aaf4ece6Schristos Put_32 (Footer (Footer'First + 4 .. Footer'Last), 649aaf4ece6Schristos Unsigned_32 (Total_In (Filter))); 650aaf4ece6Schristos Add_Data (Footer); 651aaf4ece6Schristos end; 652aaf4ece6Schristos end if; 653aaf4ece6Schristos end Translate_GZip; 654aaf4ece6Schristos 655aaf4ece6Schristos ------------- 656aaf4ece6Schristos -- Version -- 657aaf4ece6Schristos ------------- 658aaf4ece6Schristos 659aaf4ece6Schristos function Version return String is 660aaf4ece6Schristos begin 661aaf4ece6Schristos return Interfaces.C.Strings.Value (Thin.zlibVersion); 662aaf4ece6Schristos end Version; 663aaf4ece6Schristos 664aaf4ece6Schristos ----------- 665aaf4ece6Schristos -- Write -- 666aaf4ece6Schristos ----------- 667aaf4ece6Schristos 668aaf4ece6Schristos procedure Write 669aaf4ece6Schristos (Filter : in out Filter_Type; 670aaf4ece6Schristos Item : in Ada.Streams.Stream_Element_Array; 671aaf4ece6Schristos Flush : in Flush_Mode := No_Flush) 672aaf4ece6Schristos is 673aaf4ece6Schristos Buffer : Stream_Element_Array (1 .. Buffer_Size); 674aaf4ece6Schristos In_Last : Stream_Element_Offset; 675aaf4ece6Schristos Out_Last : Stream_Element_Offset; 676aaf4ece6Schristos In_First : Stream_Element_Offset := Item'First; 677aaf4ece6Schristos begin 678aaf4ece6Schristos if Item'Length = 0 and Flush = No_Flush then 679aaf4ece6Schristos return; 680aaf4ece6Schristos end if; 681aaf4ece6Schristos 682aaf4ece6Schristos loop 683aaf4ece6Schristos Translate 684aaf4ece6Schristos (Filter => Filter, 685aaf4ece6Schristos In_Data => Item (In_First .. Item'Last), 686aaf4ece6Schristos In_Last => In_Last, 687aaf4ece6Schristos Out_Data => Buffer, 688aaf4ece6Schristos Out_Last => Out_Last, 689aaf4ece6Schristos Flush => Flush); 690aaf4ece6Schristos 691aaf4ece6Schristos if Out_Last >= Buffer'First then 692aaf4ece6Schristos Write (Buffer (1 .. Out_Last)); 693aaf4ece6Schristos end if; 694aaf4ece6Schristos 695aaf4ece6Schristos exit when In_Last = Item'Last or Stream_End (Filter); 696aaf4ece6Schristos 697aaf4ece6Schristos In_First := In_Last + 1; 698aaf4ece6Schristos end loop; 699aaf4ece6Schristos end Write; 700aaf4ece6Schristos 701aaf4ece6Schristosend ZLib; 702