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 11with Ada.Exceptions; 12with Ada.Unchecked_Conversion; 13with Ada.Unchecked_Deallocation; 14 15with Interfaces.C.Strings; 16 17with ZLib.Thin; 18 19package 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 701end ZLib; 702