common/dist/zlib/contrib/ada/zlib.adb

   1 ----------------------------------------------------------------
   2 --  ZLib for Ada thick binding.                               --
   3 --                                                            --
   4 --  Copyright (C) 2002-2004 Dmitriy Anisimkov                 --
   5 --                                                            --
   6 --  Open source license information is in the zlib.ads file.  --
   7 ----------------------------------------------------------------
   8
   9 --  Id: zlib.adb,v 1.31 2004/09/06 06:53:19 vagul Exp
  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 : in Thin.Z_Streamp; Flush : in 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 : in Z_Stream);
  86    pragma Inline (Raise_Error);
  87
  88    procedure Raise_Error (Message : in String);
  89    pragma Inline (Raise_Error);
  90
  91    procedure Check_Error (Stream : in Z_Stream; Code : in 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 : in Z_Stream; Code : in 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       if not Ignore_Error and then not Is_Open (Filter) then
 142          raise Status_Error;
 143       end if;
 144
 145       Code := Flate (Filter.Compression).Done (To_Thin_Access (Filter.Strm));
 146
 147       if Ignore_Error or else Code = Thin.Z_OK then
 148          Free (Filter.Strm);
 149       else
 150          declare
 151             Error_Message : constant String
 152               := Last_Error_Message (Filter.Strm.all);
 153          begin
 154             Free (Filter.Strm);
 155             Ada.Exceptions.Raise_Exception
 156                (ZLib_Error'Identity,
 157                 Return_Code_Enum'Image (Return_Code (Code))
 158                   & ": " & Error_Message);
 159          end;
 160       end if;
 161    end Close;
 162
 163    -----------
 164    -- CRC32 --
 165    -----------
 166
 167    function CRC32
 168      (CRC  : in Unsigned_32;
 169       Data : in Ada.Streams.Stream_Element_Array)
 170       return Unsigned_32
 171    is
 172       use Thin;
 173    begin
 174       return Unsigned_32 (crc32 (ULong (CRC),
 175                                  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   := Default_Window_Bits;
 196       Memory_Level : in     Memory_Level_Type  := Default_Memory_Level;
 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       if Is_Open (Filter) then
 203          raise Status_Error;
 204       end if;
 205
 206       --  We allow ZLib to make header only in case of default header type.
 207       --  Otherwise we would either do header by ourselfs, or do not do
 208       --  header at all.
 209
 210       if Header = None or else Header = GZip then
 211          Win_Bits := -Win_Bits;
 212       end if;
 213
 214       --  For the GZip CRC calculation and make headers.
 215
 216       if Header = GZip then
 217          Filter.CRC    := 0;
 218          Filter.Offset := Simple_GZip_Header'First;
 219       else
 220          Filter.Offset := Simple_GZip_Header'Last + 1;
 221       end if;
 222
 223       Filter.Strm        := new Z_Stream;
 224       Filter.Compression := True;
 225       Filter.Stream_End  := False;
 226       Filter.Header      := Header;
 227
 228       if Thin.Deflate_Init
 229            (To_Thin_Access (Filter.Strm),
 230             Level      => Thin.Int (Level),
 231             method     => Thin.Int (Method),
 232             windowBits => Win_Bits,
 233             memLevel   => Thin.Int (Memory_Level),
 234             strategy   => Thin.Int (Strategy)) /= Thin.Z_OK
 235       then
 236          Raise_Error (Filter.Strm.all);
 237       end if;
 238    end Deflate_Init;
 239
 240    -----------
 241    -- Flush --
 242    -----------
 243
 244    procedure Flush
 245      (Filter    : in out Filter_Type;
 246       Out_Data  :    out Ada.Streams.Stream_Element_Array;
 247       Out_Last  :    out Ada.Streams.Stream_Element_Offset;
 248       Flush     : in     Flush_Mode)
 249    is
 250       No_Data : Stream_Element_Array := (1 .. 0 => 0);
 251       Last    : Stream_Element_Offset;
 252    begin
 253       Translate (Filter, No_Data, Last, Out_Data, Out_Last, Flush);
 254    end Flush;
 255
 256    -----------------------
 257    -- Generic_Translate --
 258    -----------------------
 259
 260    procedure Generic_Translate
 261      (Filter          : in out ZLib.Filter_Type;
 262       In_Buffer_Size  : in     Integer := Default_Buffer_Size;
 263       Out_Buffer_Size : in     Integer := Default_Buffer_Size)
 264    is
 265       In_Buffer  : Stream_Element_Array
 266                      (1 .. Stream_Element_Offset (In_Buffer_Size));
 267       Out_Buffer : Stream_Element_Array
 268                      (1 .. Stream_Element_Offset (Out_Buffer_Size));
 269       Last       : Stream_Element_Offset;
 270       In_Last    : Stream_Element_Offset;
 271       In_First   : Stream_Element_Offset;
 272       Out_Last   : Stream_Element_Offset;
 273    begin
 274       Main : loop
 275          Data_In (In_Buffer, Last);
 276
 277          In_First := In_Buffer'First;
 278
 279          loop
 280             Translate
 281               (Filter   => Filter,
 282                In_Data  => In_Buffer (In_First .. Last),
 283                In_Last  => In_Last,
 284                Out_Data => Out_Buffer,
 285                Out_Last => Out_Last,
 286                Flush    => Flush_Finish (Last < In_Buffer'First));
 287
 288             if Out_Buffer'First <= Out_Last then
 289                Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last));
 290             end if;
 291
 292             exit Main when Stream_End (Filter);
 293
 294             --  The end of in buffer.
 295
 296             exit when In_Last = Last;
 297
 298             In_First := In_Last + 1;
 299          end loop;
 300       end loop Main;
 301
 302    end Generic_Translate;
 303
 304    ------------------
 305    -- Inflate_Init --
 306    ------------------
 307
 308    procedure Inflate_Init
 309      (Filter      : in out Filter_Type;
 310       Window_Bits : in     Window_Bits_Type := Default_Window_Bits;
 311       Header      : in     Header_Type      := Default)
 312    is
 313       use type Thin.Int;
 314       Win_Bits : Thin.Int := Thin.Int (Window_Bits);
 315
 316       procedure Check_Version;
 317       --  Check the latest header types compatibility.
 318
 319       procedure Check_Version is
 320       begin
 321          if Version <= "1.1.4" then
 322             Raise_Error
 323               ("Inflate header type " & Header_Type'Image (Header)
 324                & " incompatible with ZLib version " & Version);
 325          end if;
 326       end Check_Version;
 327
 328    begin
 329       if Is_Open (Filter) then
 330          raise Status_Error;
 331       end if;
 332
 333       case Header is
 334          when None =>
 335             Check_Version;
 336
 337             --  Inflate data without headers determined
 338             --  by negative Win_Bits.
 339
 340             Win_Bits := -Win_Bits;
 341          when GZip =>
 342             Check_Version;
 343
 344             --  Inflate gzip data defined by flag 16.
 345
 346             Win_Bits := Win_Bits + 16;
 347          when Auto =>
 348             Check_Version;
 349
 350             --  Inflate with automatic detection
 351             --  of gzip or native header defined by flag 32.
 352
 353             Win_Bits := Win_Bits + 32;
 354          when Default => null;
 355       end case;
 356
 357       Filter.Strm        := new Z_Stream;
 358       Filter.Compression := False;
 359       Filter.Stream_End  := False;
 360       Filter.Header      := Header;
 361
 362       if Thin.Inflate_Init
 363          (To_Thin_Access (Filter.Strm), Win_Bits) /= Thin.Z_OK
 364       then
 365          Raise_Error (Filter.Strm.all);
 366       end if;
 367    end Inflate_Init;
 368
 369    -------------
 370    -- Is_Open --
 371    -------------
 372
 373    function Is_Open (Filter : in Filter_Type) return Boolean is
 374    begin
 375       return Filter.Strm /= null;
 376    end Is_Open;
 377
 378    -----------------
 379    -- Raise_Error --
 380    -----------------
 381
 382    procedure Raise_Error (Message : in String) is
 383    begin
 384       Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message);
 385    end Raise_Error;
 386
 387    procedure Raise_Error (Stream : in Z_Stream) is
 388    begin
 389       Raise_Error (Last_Error_Message (Stream));
 390    end Raise_Error;
 391
 392    ----------
 393    -- Read --
 394    ----------
 395
 396    procedure Read
 397      (Filter : in out Filter_Type;
 398       Item   :    out Ada.Streams.Stream_Element_Array;
 399       Last   :    out Ada.Streams.Stream_Element_Offset;
 400       Flush  : in     Flush_Mode := No_Flush)
 401    is
 402       In_Last    : Stream_Element_Offset;
 403       Item_First : Ada.Streams.Stream_Element_Offset := Item'First;
 404       V_Flush    : Flush_Mode := Flush;
 405
 406    begin
 407       pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1);
 408       pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last);
 409
 410       loop
 411          if Rest_Last = Buffer'First - 1 then
 412             V_Flush := Finish;
 413
 414          elsif Rest_First > Rest_Last then
 415             Read (Buffer, Rest_Last);
 416             Rest_First := Buffer'First;
 417
 418             if Rest_Last < Buffer'First then
 419                V_Flush := Finish;
 420             end if;
 421          end if;
 422
 423          Translate
 424            (Filter   => Filter,
 425             In_Data  => Buffer (Rest_First .. Rest_Last),
 426             In_Last  => In_Last,
 427             Out_Data => Item (Item_First .. Item'Last),
 428             Out_Last => Last,
 429             Flush    => V_Flush);
 430
 431          Rest_First := In_Last + 1;
 432
 433          exit when Stream_End (Filter)
 434            or else Last = Item'Last
 435            or else (Last >= Item'First and then Allow_Read_Some);
 436
 437          Item_First := Last + 1;
 438       end loop;
 439    end Read;
 440
 441    ----------------
 442    -- Stream_End --
 443    ----------------
 444
 445    function Stream_End (Filter : in Filter_Type) return Boolean is
 446    begin
 447       if Filter.Header = GZip and Filter.Compression then
 448          return Filter.Stream_End
 449             and then Filter.Offset = Footer_Array'Last + 1;
 450       else
 451          return Filter.Stream_End;
 452       end if;
 453    end Stream_End;
 454
 455    --------------
 456    -- Total_In --
 457    --------------
 458
 459    function Total_In (Filter : in Filter_Type) return Count is
 460    begin
 461       return Count (Thin.Total_In (To_Thin_Access (Filter.Strm).all));
 462    end Total_In;
 463
 464    ---------------
 465    -- Total_Out --
 466    ---------------
 467
 468    function Total_Out (Filter : in Filter_Type) return Count is
 469    begin
 470       return Count (Thin.Total_Out (To_Thin_Access (Filter.Strm).all));
 471    end Total_Out;
 472
 473    ---------------
 474    -- Translate --
 475    ---------------
 476
 477    procedure Translate
 478      (Filter    : in out Filter_Type;
 479       In_Data   : in     Ada.Streams.Stream_Element_Array;
 480       In_Last   :    out Ada.Streams.Stream_Element_Offset;
 481       Out_Data  :    out Ada.Streams.Stream_Element_Array;
 482       Out_Last  :    out Ada.Streams.Stream_Element_Offset;
 483       Flush     : in     Flush_Mode) is
 484    begin
 485       if Filter.Header = GZip and then Filter.Compression then
 486          Translate_GZip
 487            (Filter   => Filter,
 488             In_Data  => In_Data,
 489             In_Last  => In_Last,
 490             Out_Data => Out_Data,
 491             Out_Last => Out_Last,
 492             Flush    => Flush);
 493       else
 494          Translate_Auto
 495            (Filter   => Filter,
 496             In_Data  => In_Data,
 497             In_Last  => In_Last,
 498             Out_Data => Out_Data,
 499             Out_Last => Out_Last,
 500             Flush    => Flush);
 501       end if;
 502    end Translate;
 503
 504    --------------------
 505    -- Translate_Auto --
 506    --------------------
 507
 508    procedure Translate_Auto
 509      (Filter    : in out Filter_Type;
 510       In_Data   : in     Ada.Streams.Stream_Element_Array;
 511       In_Last   :    out Ada.Streams.Stream_Element_Offset;
 512       Out_Data  :    out Ada.Streams.Stream_Element_Array;
 513       Out_Last  :    out Ada.Streams.Stream_Element_Offset;
 514       Flush     : in     Flush_Mode)
 515    is
 516       use type Thin.Int;
 517       Code : Thin.Int;
 518
 519    begin
 520       if not Is_Open (Filter) then
 521          raise Status_Error;
 522       end if;
 523
 524       if Out_Data'Length = 0 and then In_Data'Length = 0 then
 525          raise Constraint_Error;
 526       end if;
 527
 528       Set_Out (Filter.Strm.all, Out_Data'Address, Out_Data'Length);
 529       Set_In  (Filter.Strm.all, In_Data'Address, In_Data'Length);
 530
 531       Code := Flate (Filter.Compression).Step
 532         (To_Thin_Access (Filter.Strm),
 533          Thin.Int (Flush));
 534
 535       if Code = Thin.Z_STREAM_END then
 536          Filter.Stream_End := True;
 537       else
 538          Check_Error (Filter.Strm.all, Code);
 539       end if;
 540
 541       In_Last  := In_Data'Last
 542          - Stream_Element_Offset (Avail_In (Filter.Strm.all));
 543       Out_Last := Out_Data'Last
 544          - Stream_Element_Offset (Avail_Out (Filter.Strm.all));
 545    end Translate_Auto;
 546
 547    --------------------
 548    -- Translate_GZip --
 549    --------------------
 550
 551    procedure Translate_GZip
 552      (Filter    : in out Filter_Type;
 553       In_Data   : in     Ada.Streams.Stream_Element_Array;
 554       In_Last   :    out Ada.Streams.Stream_Element_Offset;
 555       Out_Data  :    out Ada.Streams.Stream_Element_Array;
 556       Out_Last  :    out Ada.Streams.Stream_Element_Offset;
 557       Flush     : in     Flush_Mode)
 558    is
 559       Out_First : Stream_Element_Offset;
 560
 561       procedure Add_Data (Data : in Stream_Element_Array);
 562       --  Add data to stream from the Filter.Offset till necessary,
 563       --  used for add gzip headr/footer.
 564
 565       procedure Put_32
 566         (Item : in out Stream_Element_Array;
 567          Data : in     Unsigned_32);
 568       pragma Inline (Put_32);
 569
 570       --------------
 571       -- Add_Data --
 572       --------------
 573
 574       procedure Add_Data (Data : in Stream_Element_Array) is
 575          Data_First : Stream_Element_Offset renames Filter.Offset;
 576          Data_Last  : Stream_Element_Offset;
 577          Data_Len   : Stream_Element_Offset; --  -1
 578          Out_Len    : Stream_Element_Offset; --  -1
 579       begin
 580          Out_First := Out_Last + 1;
 581
 582          if Data_First > Data'Last then
 583             return;
 584          end if;
 585
 586          Data_Len  := Data'Last     - Data_First;
 587          Out_Len   := Out_Data'Last - Out_First;
 588
 589          if Data_Len <= Out_Len then
 590             Out_Last  := Out_First  + Data_Len;
 591             Data_Last := Data'Last;
 592          else
 593             Out_Last  := Out_Data'Last;
 594             Data_Last := Data_First + Out_Len;
 595          end if;
 596
 597          Out_Data (Out_First .. Out_Last) := Data (Data_First .. Data_Last);
 598
 599          Data_First := Data_Last + 1;
 600          Out_First  := Out_Last + 1;
 601       end Add_Data;
 602
 603       ------------
 604       -- Put_32 --
 605       ------------
 606
 607       procedure Put_32
 608         (Item : in out Stream_Element_Array;
 609          Data : in     Unsigned_32)
 610       is
 611          D : Unsigned_32 := Data;
 612       begin
 613          for J in Item'First .. Item'First + 3 loop
 614             Item (J) := Stream_Element (D and 16#FF#);
 615             D := Shift_Right (D, 8);
 616          end loop;
 617       end Put_32;
 618
 619    begin
 620       Out_Last := Out_Data'First - 1;
 621
 622       if not Filter.Stream_End then
 623          Add_Data (Simple_GZip_Header);
 624
 625          Translate_Auto
 626            (Filter   => Filter,
 627             In_Data  => In_Data,
 628             In_Last  => In_Last,
 629             Out_Data => Out_Data (Out_First .. Out_Data'Last),
 630             Out_Last => Out_Last,
 631             Flush    => Flush);
 632
 633          CRC32 (Filter.CRC, In_Data (In_Data'First .. In_Last));
 634       end if;
 635
 636       if Filter.Stream_End and then Out_Last <= Out_Data'Last then
 637          --  This detection method would work only when
 638          --  Simple_GZip_Header'Last > Footer_Array'Last
 639
 640          if Filter.Offset = Simple_GZip_Header'Last + 1 then
 641             Filter.Offset := Footer_Array'First;
 642          end if;
 643
 644          declare
 645             Footer : Footer_Array;
 646          begin
 647             Put_32 (Footer, Filter.CRC);
 648             Put_32 (Footer (Footer'First + 4 .. Footer'Last),
 649                     Unsigned_32 (Total_In (Filter)));
 650             Add_Data (Footer);
 651          end;
 652       end if;
 653    end Translate_GZip;
 654
 655    -------------
 656    -- Version --
 657    -------------
 658
 659    function Version return String is
 660    begin
 661       return Interfaces.C.Strings.Value (Thin.zlibVersion);
 662    end Version;
 663
 664    -----------
 665    -- Write --
 666    -----------
 667
 668    procedure Write
 669      (Filter : in out Filter_Type;
 670       Item   : in     Ada.Streams.Stream_Element_Array;
 671       Flush  : in     Flush_Mode := No_Flush)
 672    is
 673       Buffer   : Stream_Element_Array (1 .. Buffer_Size);
 674       In_Last  : Stream_Element_Offset;
 675       Out_Last : Stream_Element_Offset;
 676       In_First : Stream_Element_Offset := Item'First;
 677    begin
 678       if Item'Length = 0 and Flush = No_Flush then
 679          return;
 680       end if;
 681
 682       loop
 683          Translate
 684            (Filter   => Filter,
 685             In_Data  => Item (In_First .. Item'Last),
 686             In_Last  => In_Last,
 687             Out_Data => Buffer,
 688             Out_Last => Out_Last,
 689             Flush    => Flush);
 690
 691          if Out_Last >= Buffer'First then
 692             Write (Buffer (1 .. Out_Last));
 693          end if;
 694
 695          exit when In_Last = Item'Last or Stream_End (Filter);
 696
 697          In_First := In_Last + 1;
 698       end loop;
 699    end Write;
 700
 701 end ZLib;