runtime/zlib/contrib/ada/zlib.adb

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