• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
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