summaryrefslogtreecommitdiff
path: root/contrib/ada/zlib.adb
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/ada/zlib.adb')
-rw-r--r--contrib/ada/zlib.adb143
1 files changed, 85 insertions, 58 deletions
diff --git a/contrib/ada/zlib.adb b/contrib/ada/zlib.adb
index 93bf885..8b6fd68 100644
--- a/contrib/ada/zlib.adb
+++ b/contrib/ada/zlib.adb
@@ -1,12 +1,12 @@
1---------------------------------------------------------------- 1----------------------------------------------------------------
2-- ZLib for Ada thick binding. -- 2-- ZLib for Ada thick binding. --
3-- -- 3-- --
4-- Copyright (C) 2002-2003 Dmitriy Anisimkov -- 4-- Copyright (C) 2002-2004 Dmitriy Anisimkov --
5-- -- 5-- --
6-- Open source license information is in the zlib.ads file. -- 6-- Open source license information is in the zlib.ads file. --
7---------------------------------------------------------------- 7----------------------------------------------------------------
8 8
9-- $Id: zlib.adb,v 1.19 2003/07/13 16:02:19 vagul Exp $ 9-- $Id: zlib.adb,v 1.31 2004/09/06 06:53:19 vagul Exp $
10 10
11with Ada.Exceptions; 11with Ada.Exceptions;
12with Ada.Unchecked_Conversion; 12with Ada.Unchecked_Conversion;
@@ -34,7 +34,7 @@ package body ZLib is
34 VERSION_ERROR); 34 VERSION_ERROR);
35 35
36 type Flate_Step_Function is access 36 type Flate_Step_Function is access
37 function (Strm : Thin.Z_Streamp; flush : Thin.Int) return Thin.Int; 37 function (Strm : in Thin.Z_Streamp; Flush : in Thin.Int) return Thin.Int;
38 pragma Convention (C, Flate_Step_Function); 38 pragma Convention (C, Flate_Step_Function);
39 39
40 type Flate_End_Function is access 40 type Flate_End_Function is access
@@ -82,13 +82,13 @@ package body ZLib is
82 Flush_Finish : constant array (Boolean) of Flush_Mode 82 Flush_Finish : constant array (Boolean) of Flush_Mode
83 := (True => Finish, False => No_Flush); 83 := (True => Finish, False => No_Flush);
84 84
85 procedure Raise_Error (Stream : Z_Stream); 85 procedure Raise_Error (Stream : in Z_Stream);
86 pragma Inline (Raise_Error); 86 pragma Inline (Raise_Error);
87 87
88 procedure Raise_Error (Message : String); 88 procedure Raise_Error (Message : in String);
89 pragma Inline (Raise_Error); 89 pragma Inline (Raise_Error);
90 90
91 procedure Check_Error (Stream : Z_Stream; Code : Thin.Int); 91 procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int);
92 92
93 procedure Free is new Ada.Unchecked_Deallocation 93 procedure Free is new Ada.Unchecked_Deallocation
94 (Z_Stream, Z_Stream_Access); 94 (Z_Stream, Z_Stream_Access);
@@ -118,7 +118,7 @@ package body ZLib is
118 -- Check_Error -- 118 -- Check_Error --
119 ----------------- 119 -----------------
120 120
121 procedure Check_Error (Stream : Z_Stream; Code : Thin.Int) is 121 procedure Check_Error (Stream : in Z_Stream; Code : in Thin.Int) is
122 use type Thin.Int; 122 use type Thin.Int;
123 begin 123 begin
124 if Code /= Thin.Z_OK then 124 if Code /= Thin.Z_OK then
@@ -138,10 +138,11 @@ package body ZLib is
138 is 138 is
139 Code : Thin.Int; 139 Code : Thin.Int;
140 begin 140 begin
141 Code := Flate (Filter.Compression).Done 141 if not Ignore_Error and then not Is_Open (Filter) then
142 (To_Thin_Access (Filter.Strm)); 142 raise Status_Error;
143 end if;
143 144
144 Filter.Opened := False; 145 Code := Flate (Filter.Compression).Done (To_Thin_Access (Filter.Strm));
145 146
146 if Ignore_Error or else Code = Thin.Z_OK then 147 if Ignore_Error or else Code = Thin.Z_OK then
147 Free (Filter.Strm); 148 Free (Filter.Strm);
@@ -154,7 +155,7 @@ package body ZLib is
154 Ada.Exceptions.Raise_Exception 155 Ada.Exceptions.Raise_Exception
155 (ZLib_Error'Identity, 156 (ZLib_Error'Identity,
156 Return_Code_Enum'Image (Return_Code (Code)) 157 Return_Code_Enum'Image (Return_Code (Code))
157 & ": " & Error_Message); 158 & ": " & Error_Message);
158 end; 159 end;
159 end if; 160 end if;
160 end Close; 161 end Close;
@@ -170,10 +171,9 @@ package body ZLib is
170 is 171 is
171 use Thin; 172 use Thin;
172 begin 173 begin
173 return Unsigned_32 (crc32 174 return Unsigned_32 (crc32 (ULong (CRC),
174 (ULong (CRC), 175 Data'Address,
175 Bytes.To_Pointer (Data'Address), 176 Data'Length));
176 Data'Length));
177 end CRC32; 177 end CRC32;
178 178
179 procedure CRC32 179 procedure CRC32
@@ -192,13 +192,17 @@ package body ZLib is
192 Level : in Compression_Level := Default_Compression; 192 Level : in Compression_Level := Default_Compression;
193 Strategy : in Strategy_Type := Default_Strategy; 193 Strategy : in Strategy_Type := Default_Strategy;
194 Method : in Compression_Method := Deflated; 194 Method : in Compression_Method := Deflated;
195 Window_Bits : in Window_Bits_Type := 15; 195 Window_Bits : in Window_Bits_Type := Default_Window_Bits;
196 Memory_Level : in Memory_Level_Type := 8; 196 Memory_Level : in Memory_Level_Type := Default_Memory_Level;
197 Header : in Header_Type := Default) 197 Header : in Header_Type := Default)
198 is 198 is
199 use type Thin.Int; 199 use type Thin.Int;
200 Win_Bits : Thin.Int := Thin.Int (Window_Bits); 200 Win_Bits : Thin.Int := Thin.Int (Window_Bits);
201 begin 201 begin
202 if Is_Open (Filter) then
203 raise Status_Error;
204 end if;
205
202 -- We allow ZLib to make header only in case of default header type. 206 -- 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 207 -- Otherwise we would either do header by ourselfs, or do not do
204 -- header at all. 208 -- header at all.
@@ -216,10 +220,9 @@ package body ZLib is
216 Filter.Offset := Simple_GZip_Header'Last + 1; 220 Filter.Offset := Simple_GZip_Header'Last + 1;
217 end if; 221 end if;
218 222
219 Filter.Strm := new Z_Stream; 223 Filter.Strm := new Z_Stream;
220 Filter.Compression := True; 224 Filter.Compression := True;
221 Filter.Stream_End := False; 225 Filter.Stream_End := False;
222 Filter.Opened := True;
223 Filter.Header := Header; 226 Filter.Header := Header;
224 227
225 if Thin.Deflate_Init 228 if Thin.Deflate_Init
@@ -255,18 +258,18 @@ package body ZLib is
255 ----------------------- 258 -----------------------
256 259
257 procedure Generic_Translate 260 procedure Generic_Translate
258 (Filter : in out ZLib.Filter_Type; 261 (Filter : in out ZLib.Filter_Type;
259 In_Buffer_Size : Integer := Default_Buffer_Size; 262 In_Buffer_Size : in Integer := Default_Buffer_Size;
260 Out_Buffer_Size : Integer := Default_Buffer_Size) 263 Out_Buffer_Size : in Integer := Default_Buffer_Size)
261 is 264 is
262 In_Buffer : Stream_Element_Array 265 In_Buffer : Stream_Element_Array
263 (1 .. Stream_Element_Offset (In_Buffer_Size)); 266 (1 .. Stream_Element_Offset (In_Buffer_Size));
264 Out_Buffer : Stream_Element_Array 267 Out_Buffer : Stream_Element_Array
265 (1 .. Stream_Element_Offset (Out_Buffer_Size)); 268 (1 .. Stream_Element_Offset (Out_Buffer_Size));
266 Last : Stream_Element_Offset; 269 Last : Stream_Element_Offset;
267 In_Last : Stream_Element_Offset; 270 In_Last : Stream_Element_Offset;
268 In_First : Stream_Element_Offset; 271 In_First : Stream_Element_Offset;
269 Out_Last : Stream_Element_Offset; 272 Out_Last : Stream_Element_Offset;
270 begin 273 begin
271 Main : loop 274 Main : loop
272 Data_In (In_Buffer, Last); 275 Data_In (In_Buffer, Last);
@@ -275,18 +278,21 @@ package body ZLib is
275 278
276 loop 279 loop
277 Translate 280 Translate
278 (Filter, 281 (Filter => Filter,
279 In_Buffer (In_First .. Last), 282 In_Data => In_Buffer (In_First .. Last),
280 In_Last, 283 In_Last => In_Last,
281 Out_Buffer, 284 Out_Data => Out_Buffer,
282 Out_Last, 285 Out_Last => Out_Last,
283 Flush_Finish (Last < In_Buffer'First)); 286 Flush => Flush_Finish (Last < In_Buffer'First));
284 287
285 Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last)); 288 if Out_Buffer'First <= Out_Last then
289 Data_Out (Out_Buffer (Out_Buffer'First .. Out_Last));
290 end if;
286 291
287 exit Main when Stream_End (Filter); 292 exit Main when Stream_End (Filter);
288 293
289 -- The end of in buffer. 294 -- The end of in buffer.
295
290 exit when In_Last = Last; 296 exit when In_Last = Last;
291 297
292 In_First := In_Last + 1; 298 In_First := In_Last + 1;
@@ -301,7 +307,7 @@ package body ZLib is
301 307
302 procedure Inflate_Init 308 procedure Inflate_Init
303 (Filter : in out Filter_Type; 309 (Filter : in out Filter_Type;
304 Window_Bits : in Window_Bits_Type := 15; 310 Window_Bits : in Window_Bits_Type := Default_Window_Bits;
305 Header : in Header_Type := Default) 311 Header : in Header_Type := Default)
306 is 312 is
307 use type Thin.Int; 313 use type Thin.Int;
@@ -320,6 +326,10 @@ package body ZLib is
320 end Check_Version; 326 end Check_Version;
321 327
322 begin 328 begin
329 if Is_Open (Filter) then
330 raise Status_Error;
331 end if;
332
323 case Header is 333 case Header is
324 when None => 334 when None =>
325 Check_Version; 335 Check_Version;
@@ -344,10 +354,9 @@ package body ZLib is
344 when Default => null; 354 when Default => null;
345 end case; 355 end case;
346 356
347 Filter.Strm := new Z_Stream; 357 Filter.Strm := new Z_Stream;
348 Filter.Compression := False; 358 Filter.Compression := False;
349 Filter.Stream_End := False; 359 Filter.Stream_End := False;
350 Filter.Opened := True;
351 Filter.Header := Header; 360 Filter.Header := Header;
352 361
353 if Thin.Inflate_Init 362 if Thin.Inflate_Init
@@ -357,16 +366,25 @@ package body ZLib is
357 end if; 366 end if;
358 end Inflate_Init; 367 end Inflate_Init;
359 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
360 ----------------- 378 -----------------
361 -- Raise_Error -- 379 -- Raise_Error --
362 ----------------- 380 -----------------
363 381
364 procedure Raise_Error (Message : String) is 382 procedure Raise_Error (Message : in String) is
365 begin 383 begin
366 Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message); 384 Ada.Exceptions.Raise_Exception (ZLib_Error'Identity, Message);
367 end Raise_Error; 385 end Raise_Error;
368 386
369 procedure Raise_Error (Stream : Z_Stream) is 387 procedure Raise_Error (Stream : in Z_Stream) is
370 begin 388 begin
371 Raise_Error (Last_Error_Message (Stream)); 389 Raise_Error (Last_Error_Message (Stream));
372 end Raise_Error; 390 end Raise_Error;
@@ -378,21 +396,29 @@ package body ZLib is
378 procedure Read 396 procedure Read
379 (Filter : in out Filter_Type; 397 (Filter : in out Filter_Type;
380 Item : out Ada.Streams.Stream_Element_Array; 398 Item : out Ada.Streams.Stream_Element_Array;
381 Last : out Ada.Streams.Stream_Element_Offset) 399 Last : out Ada.Streams.Stream_Element_Offset;
400 Flush : in Flush_Mode := No_Flush)
382 is 401 is
383 In_Last : Stream_Element_Offset; 402 In_Last : Stream_Element_Offset;
384 Item_First : Ada.Streams.Stream_Element_Offset := Item'First; 403 Item_First : Ada.Streams.Stream_Element_Offset := Item'First;
404 V_Flush : Flush_Mode := Flush;
385 405
386 begin 406 begin
387 pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1); 407 pragma Assert (Rest_First in Buffer'First .. Buffer'Last + 1);
408 pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last);
388 409
389 loop 410 loop
390 if Rest_First > Buffer'Last then 411 if Rest_Last = Buffer'First - 1 then
412 V_Flush := Finish;
413
414 elsif Rest_First > Rest_Last then
391 Read (Buffer, Rest_Last); 415 Read (Buffer, Rest_Last);
392 Rest_First := Buffer'First; 416 Rest_First := Buffer'First;
393 end if;
394 417
395 pragma Assert (Rest_Last in Buffer'First - 1 .. Buffer'Last); 418 if Rest_Last < Buffer'First then
419 V_Flush := Finish;
420 end if;
421 end if;
396 422
397 Translate 423 Translate
398 (Filter => Filter, 424 (Filter => Filter,
@@ -400,11 +426,13 @@ package body ZLib is
400 In_Last => In_Last, 426 In_Last => In_Last,
401 Out_Data => Item (Item_First .. Item'Last), 427 Out_Data => Item (Item_First .. Item'Last),
402 Out_Last => Last, 428 Out_Last => Last,
403 Flush => Flush_Finish (Rest_Last < Rest_First)); 429 Flush => V_Flush);
404 430
405 Rest_First := In_Last + 1; 431 Rest_First := In_Last + 1;
406 432
407 exit when Last = Item'Last or else Stream_End (Filter); 433 exit when Stream_End (Filter)
434 or else Last = Item'Last
435 or else (Last >= Item'First and then Allow_Read_Some);
408 436
409 Item_First := Last + 1; 437 Item_First := Last + 1;
410 end loop; 438 end loop;
@@ -489,11 +517,11 @@ package body ZLib is
489 Code : Thin.Int; 517 Code : Thin.Int;
490 518
491 begin 519 begin
492 if Filter.Opened = False then 520 if not Is_Open (Filter) then
493 raise ZLib_Error; 521 raise Status_Error;
494 end if; 522 end if;
495 523
496 if Out_Data'Length = 0 then 524 if Out_Data'Length = 0 and then In_Data'Length = 0 then
497 raise Constraint_Error; 525 raise Constraint_Error;
498 end if; 526 end if;
499 527
@@ -514,7 +542,6 @@ package body ZLib is
514 - Stream_Element_Offset (Avail_In (Filter.Strm.all)); 542 - Stream_Element_Offset (Avail_In (Filter.Strm.all));
515 Out_Last := Out_Data'Last 543 Out_Last := Out_Data'Last
516 - Stream_Element_Offset (Avail_Out (Filter.Strm.all)); 544 - Stream_Element_Offset (Avail_Out (Filter.Strm.all));
517
518 end Translate_Auto; 545 end Translate_Auto;
519 546
520 -------------------- 547 --------------------
@@ -529,7 +556,7 @@ package body ZLib is
529 Out_Last : out Ada.Streams.Stream_Element_Offset; 556 Out_Last : out Ada.Streams.Stream_Element_Offset;
530 Flush : in Flush_Mode) 557 Flush : in Flush_Mode)
531 is 558 is
532 Out_First : Stream_Element_Offset; 559 Out_First : Stream_Element_Offset;
533 560
534 procedure Add_Data (Data : in Stream_Element_Array); 561 procedure Add_Data (Data : in Stream_Element_Array);
535 -- Add data to stream from the Filter.Offset till necessary, 562 -- Add data to stream from the Filter.Offset till necessary,
@@ -596,7 +623,7 @@ package body ZLib is
596 Add_Data (Simple_GZip_Header); 623 Add_Data (Simple_GZip_Header);
597 624
598 Translate_Auto 625 Translate_Auto
599 (Filter => Filter, 626 (Filter => Filter,
600 In_Data => In_Data, 627 In_Data => In_Data,
601 In_Last => In_Last, 628 In_Last => In_Last,
602 Out_Data => Out_Data (Out_First .. Out_Data'Last), 629 Out_Data => Out_Data (Out_First .. Out_Data'Last),
@@ -604,7 +631,6 @@ package body ZLib is
604 Flush => Flush); 631 Flush => Flush);
605 632
606 CRC32 (Filter.CRC, In_Data (In_Data'First .. In_Last)); 633 CRC32 (Filter.CRC, In_Data (In_Data'First .. In_Last));
607
608 end if; 634 end if;
609 635
610 if Filter.Stream_End and then Out_Last <= Out_Data'Last then 636 if Filter.Stream_End and then Out_Last <= Out_Data'Last then
@@ -642,10 +668,11 @@ package body ZLib is
642 procedure Write 668 procedure Write
643 (Filter : in out Filter_Type; 669 (Filter : in out Filter_Type;
644 Item : in Ada.Streams.Stream_Element_Array; 670 Item : in Ada.Streams.Stream_Element_Array;
645 Flush : in Flush_Mode) 671 Flush : in Flush_Mode := No_Flush)
646 is 672 is
647 Buffer : Stream_Element_Array (1 .. Buffer_Size); 673 Buffer : Stream_Element_Array (1 .. Buffer_Size);
648 In_Last, Out_Last : Stream_Element_Offset; 674 In_Last : Stream_Element_Offset;
675 Out_Last : Stream_Element_Offset;
649 In_First : Stream_Element_Offset := Item'First; 676 In_First : Stream_Element_Offset := Item'First;
650 begin 677 begin
651 if Item'Length = 0 and Flush = No_Flush then 678 if Item'Length = 0 and Flush = No_Flush then
@@ -654,7 +681,7 @@ package body ZLib is
654 681
655 loop 682 loop
656 Translate 683 Translate
657 (Filter => Filter, 684 (Filter => Filter,
658 In_Data => Item (In_First .. Item'Last), 685 In_Data => Item (In_First .. Item'Last),
659 In_Last => In_Last, 686 In_Last => In_Last,
660 Out_Data => Buffer, 687 Out_Data => Buffer,