source: s10k/CommonLibs/zlib-1.2.8/contrib/ada/zlib.adb@ 1105

Last change on this file since 1105 was 1096, checked in by s10k, 7 years ago

Added zlib, quazip, basicxmlsyntaxhighlighter, conditionalsemaphore and linenumberdisplay libraries. zlib and quazip are pre-compiled, but you can compile them yourself, just delete the dll files (or equivalent binary files to your OS)
File size: 19.9 KB
RevLine 
[1096]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;
Note: See TracBrowser for help on using the repository browser.