Source file : unzip-decompress.adb
1 -- UnZip.Decompress
2 --------------------
3 -- Internal to the UnZip package. See root package (UnZip) for details & credits.
4
5 -- Legal licensing note:
6
7 -- Copyright (c) 2007 .. 2024 Gautier de Montmollin
8 -- SWITZERLAND
9
10 -- Permission is hereby granted, free of charge, to any person obtaining a copy
11 -- of this software and associated documentation files (the "Software"), to deal
12 -- in the Software without restriction, including without limitation the rights
13 -- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
14 -- copies of the Software, and to permit persons to whom the Software is
15 -- furnished to do so, subject to the following conditions:
16
17 -- The above copyright notice and this permission notice shall be included in
18 -- all copies or substantial portions of the Software.
19
20 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
21 -- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
22 -- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
23 -- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
24 -- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
25 -- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
26 -- THE SOFTWARE.
27
28 -- NB: this is the MIT License, as found on the site
29 -- http://www.opensource.org/licenses/mit-license.php
30
31 with Zip.CRC_Crypto, UnZip.Decompress.Huffman, BZip2.Decoding, LZMA.Decoding;
32
33 with Ada.Exceptions, Ada.Streams.Stream_IO, Ada.Text_IO, Interfaces;
34
35 package body UnZip.Decompress is
36
37 procedure Decompress_Data
38 (zip_file : in out Zip_Streams.Root_Zipstream_Type'Class;
39 -- zip_file must be open and its index is meant
40 -- to point to the beginning of compressed data
41 format : in Zip.PKZip_method;
42 write_mode : in Write_Mode_Type;
43 output_file_name : in String; -- relevant only if mode = write_to_file
44 output_memory_access : out p_Stream_Element_Array; -- \ = write_to_memory
45 output_stream_access : in p_Stream; -- \ = write_to_stream
46 feedback : in Zip.Feedback_Proc;
47 explode_literal_tree : in Boolean; -- relevant for the "explode" format
48 explode_slide_8KB_LZMA_EOS : in Boolean; -- relevant for the "explode" and "LZMA" formats
49 data_descriptor_after_data : in Boolean;
50 is_encrypted : in Boolean;
51 password : in out Ada.Strings.Unbounded.Unbounded_String;
52 get_new_password : in Get_Password_Proc; -- if null, initial pwd must fit
53 hint : in out Zip.Headers.Local_File_Header)
54 is
55 -- Disable AdaControl rule for detecting global variables, they have become local here.
56 --## RULE OFF Directly_Accessed_Globals
57 --
58 -- I/O Buffers: Size of input buffer
59 inbuf_size : constant := 16#8000#; -- (orig: 16#1000# B = 4 KiB)
60 -- I/O Buffers: Size of sliding dictionary and output buffer
61 wsize : constant := 16#10000#; -- (orig: 16#8000# B = 32 KiB)
62
63 ----------------------------------------------------------------------------
64 -- Specifications of UnZ_* packages (remain of Info Zip's code structure) --
65 ----------------------------------------------------------------------------
66 use Ada.Exceptions, Interfaces;
67
68 package UnZ_Glob is -- Not global anymore, since local to Decompress_data :-)
69 -- I/O Buffers: Sliding dictionary for unzipping, and output buffer as well
70 slide : Zip.Byte_Buffer (0 .. wsize);
71 slide_index : Integer := 0; -- Current Position in slide
72 -- I/O Buffers: Input buffer
73 inbuf : Zip.Byte_Buffer (0 .. inbuf_size - 1);
74 inpos, readpos : Integer; -- pos. in input buffer, pos. read from file
75 compsize, -- compressed size of file
76 reachedsize, -- number of bytes read from zipfile
77 uncompsize, -- uncompressed size of file
78 effective_writes : Zip.Zip_64_Data_Size_Type;
79 -- ^ count of effective bytes written or tested, for feedback only
80 percents_done : Natural;
81 crc32val : Unsigned_32; -- crc calculated from data
82 uncompressed_index : Ada.Streams.Stream_Element_Offset;
83 end UnZ_Glob;
84
85 Zip_EOF : Boolean; -- read over end of zip section for this file
86 LZ77_dump : Ada.Text_IO.File_Type;
87
88 package UnZ_IO is
89 out_bin_file : Ada.Streams.Stream_IO.File_Type;
90 out_txt_file : Ada.Text_IO.File_Type;
91 last_char : Character := ' ';
92
93 procedure Init_Buffers;
94
95 procedure Read_Byte_no_Decrypt (bt : out Zip.Byte);
96 pragma Inline (Read_Byte_no_Decrypt);
97
98 function Read_Byte_Decrypted return Unsigned_8; -- NB: reading goes on a while even if
99 pragma Inline (Read_Byte_Decrypted); -- Zip_EOF is set: just gives garbage
100
101 package Bit_buffer is
102 procedure Init;
103 -- Read at least n bits into the bit buffer, returns the n first bits
104 function Read (n : Natural) return Integer;
105 pragma Inline (Read);
106 function Read_U32 (n : Natural) return Unsigned_32;
107 pragma Inline (Read_U32);
108 -- Inverts (NOT operator) the result before masking by n bits
109 function Read_inverted (n : Natural) return Integer;
110 pragma Inline (Read_inverted);
111 -- Dump n bits no longer needed from the bit buffer
112 procedure Dump (n : Natural);
113 pragma Inline (Dump);
114 procedure Dump_to_byte_boundary;
115 function Read_and_dump (n : Natural) return Integer;
116 pragma Inline (Read_and_dump);
117 function Read_and_dump_U32 (n : Natural) return Unsigned_32;
118 pragma Inline (Read_and_dump_U32);
119 end Bit_buffer;
120
121 procedure Flush (x : Natural); -- directly from slide to output stream
122
123 procedure Flush_if_full (W : in out Integer; unflushed : in out Boolean);
124 pragma Inline (Flush_if_full);
125
126 procedure Flush_if_full (W : in out Integer);
127 pragma Inline (Flush_if_full);
128
129 procedure Copy (distance, copy_length : Natural; index : in out Natural);
130 pragma Inline (Copy);
131
132 procedure Copy_or_zero (
133 distance, length : Natural;
134 index : in out Natural;
135 unflushed : in out Boolean);
136 pragma Inline (Copy_or_zero);
137
138 procedure Delete_output; -- an error has occured (bad compressed data)
139
140 end UnZ_IO;
141
142 package UnZ_Meth is
143 procedure Copy_stored;
144 procedure Unshrink;
145 subtype Reduction_factor is Integer range 1 .. 4;
146 procedure Unreduce (factor : Reduction_factor);
147 procedure Explode (literal_tree, slide_8_KB : Boolean);
148 deflate_e_mode : Boolean := False;
149 procedure Inflate;
150 procedure Bunzip2; -- Nov-2009
151 procedure LZMA_Decode; -- Jun-2014
152 end UnZ_Meth;
153
154 procedure Process_feedback (new_bytes : Zip.Zip_64_Data_Size_Type) is
155 pragma Inline (Process_feedback);
156 new_percents_done : Natural;
157 user_aborting : Boolean;
158 use Zip;
159 begin
160 if feedback = null or UnZ_Glob.uncompsize = 0 then
161 return; -- no feedback proc. or cannot calculate percentage
162 end if;
163 UnZ_Glob.effective_writes := UnZ_Glob.effective_writes + new_bytes;
164 new_percents_done := Natural (
165 (100.0 * Float (UnZ_Glob.effective_writes)) / Float (UnZ_Glob.uncompsize)
166 );
167 if new_percents_done > UnZ_Glob.percents_done then
168 feedback (
169 percents_done => new_percents_done,
170 entry_skipped => False,
171 user_abort => user_aborting
172 );
173 if user_aborting then
174 raise User_abort;
175 end if;
176 UnZ_Glob.percents_done := new_percents_done;
177 end if;
178 end Process_feedback;
179
180 use Zip.CRC_Crypto;
181 local_crypto_pack : Crypto_pack;
182
183 ------------------------------
184 -- Bodies of UnZ_* packages --
185 ------------------------------
186 package body UnZ_IO is
187
188 procedure Init_Buffers is
189 begin
190 UnZ_Glob.inpos := 0; -- Input buffer position
191 UnZ_Glob.readpos := -1; -- Nothing read
192 UnZ_Glob.slide_index := 0;
193 UnZ_Glob.reachedsize := 0;
194 UnZ_Glob.effective_writes := 0;
195 UnZ_Glob.percents_done := 0;
196 Zip_EOF := False;
197 Zip.CRC_Crypto.Init (UnZ_Glob.crc32val);
198 Bit_buffer.Init;
199 end Init_Buffers;
200
201 procedure Process_compressed_end_reached is
202 begin
203 if Zip_EOF then -- We came already here once
204 raise Zip.Archive_corrupted with
205 "Decoding went past compressed data size plus one buffer length";
206 -- Avoid infinite loop on data with exactly buffer's length and no end marker
207 else
208 UnZ_Glob.readpos := UnZ_Glob.inbuf'Length;
209 -- Simulates reading -> no blocking.
210 -- The buffer is full of "random" data.
211 -- A correct compressed stream will hit its own end-of-compressed-stream.
212 -- On a corrupted data we will get a wrong code or a CRC error on the way.
213 Zip_EOF := True;
214 end if;
215 end Process_compressed_end_reached;
216
217 procedure Read_buffer is
218 begin
219 if full_trace then
220 Ada.Text_IO.Put ("[Read_buffer...");
221 end if;
222 if UnZ_Glob.reachedsize > UnZ_Glob.compsize + 2 then
223 -- +2: last code is smaller than requested!
224 Process_compressed_end_reached;
225 else
226 begin
227 Zip.Block_Read (
228 stream => zip_file,
229 buffer => UnZ_Glob.inbuf,
230 actually_read => UnZ_Glob.readpos
231 );
232 exception
233 when others => -- I/O error
234 Process_compressed_end_reached;
235 end;
236 if UnZ_Glob.readpos = 0 then -- No byte at all was read
237 Process_compressed_end_reached;
238 end if;
239 UnZ_Glob.reachedsize :=
240 UnZ_Glob.reachedsize + Zip.Zip_64_Data_Size_Type (UnZ_Glob.readpos);
241 UnZ_Glob.readpos := UnZ_Glob.readpos - 1; -- Reason: index of inbuf starts at 0
242 end if;
243 UnZ_Glob.inpos := 0;
244 if full_trace then
245 Ada.Text_IO.Put_Line ("finished]");
246 end if;
247 end Read_buffer;
248
249 procedure Read_Byte_no_Decrypt (bt : out Zip.Byte) is
250 begin
251 if UnZ_Glob.inpos > UnZ_Glob.readpos then
252 Read_buffer;
253 end if;
254 bt := UnZ_Glob.inbuf (UnZ_Glob.inpos);
255 UnZ_Glob.inpos := UnZ_Glob.inpos + 1;
256 end Read_Byte_no_Decrypt;
257
258 function Read_Byte_Decrypted return Unsigned_8 is
259 bt : Zip.Byte;
260 begin
261 Read_Byte_no_Decrypt (bt);
262 Decode (local_crypto_pack, bt);
263 return bt;
264 end Read_Byte_Decrypted;
265
266 package body Bit_buffer is
267 B : Unsigned_32;
268 K : Integer;
269
270 procedure Init is
271 begin
272 B := 0;
273 K := 0;
274 end Init;
275
276 procedure Need (n : Natural) is
277 pragma Inline (Need);
278 begin
279 while K < n loop
280 B := B or Shift_Left (Unsigned_32 (Read_Byte_Decrypted), K);
281 K := K + 8;
282 end loop;
283 end Need;
284
285 procedure Dump (n : Natural) is
286 begin
287 B := Shift_Right (B, n);
288 K := K - n;
289 end Dump;
290
291 procedure Dump_to_byte_boundary is
292 begin
293 Dump (K mod 8);
294 end Dump_to_byte_boundary;
295
296 function Read_U32 (n : Natural) return Unsigned_32 is
297 begin
298 Need (n);
299 return B and (Shift_Left (1, n) - 1);
300 end Read_U32;
301
302 function Read_inverted (n : Natural) return Integer is
303 begin
304 Need (n);
305 return Integer ((not B) and (Shift_Left (1, n) - 1));
306 end Read_inverted;
307
308 function Read (n : Natural) return Integer is
309 begin
310 return Integer (Read_U32 (n));
311 end Read;
312
313 function Read_and_dump (n : Natural) return Integer is
314 res : Integer;
315 begin
316 res := Read (n);
317 Dump (n);
318 return res;
319 end Read_and_dump;
320
321 function Read_and_dump_U32 (n : Natural) return Unsigned_32 is
322 res : Unsigned_32;
323 begin
324 res := Read_U32 (n);
325 Dump (n);
326 return res;
327 end Read_and_dump_U32;
328
329 end Bit_buffer;
330
331 procedure Flush (x : Natural) is
332 use Zip, Ada.Streams;
333 begin
334 if full_trace then
335 Ada.Text_IO.Put ("[Flush...");
336 end if;
337 begin
338 case write_mode is
339 when write_to_binary_file =>
340 Block_Write (Ada.Streams.Stream_IO.Stream (out_bin_file).all, UnZ_Glob.slide (0 .. x - 1));
341 when write_to_text_file =>
342 Write_as_Text
343 (UnZ_IO.out_txt_file, UnZ_Glob.slide (0 .. x - 1), UnZ_IO.last_char);
344 when write_to_memory =>
345 for i in 0 .. x - 1 loop
346 output_memory_access (UnZ_Glob.uncompressed_index) :=
347 Ada.Streams.Stream_Element (UnZ_Glob.slide (i));
348 UnZ_Glob.uncompressed_index := UnZ_Glob.uncompressed_index + 1;
349 end loop;
350 when write_to_stream =>
351 Block_Write (output_stream_access.all, UnZ_Glob.slide (0 .. x - 1));
352 when just_test =>
353 null;
354 end case;
355 exception
356 when others =>
357 raise UnZip.Write_Error;
358 end;
359 Zip.CRC_Crypto.Update (UnZ_Glob.crc32val, UnZ_Glob.slide (0 .. x - 1));
360 Process_feedback (Zip_64_Data_Size_Type (x));
361 if full_trace then
362 Ada.Text_IO.Put_Line ("finished]");
363 end if;
364 end Flush;
365
366 procedure Flush_if_full (W : in out Integer; unflushed : in out Boolean) is
367 begin
368 if W = wsize then
369 Flush (wsize);
370 W := 0;
371 unflushed := False;
372 end if;
373 end Flush_if_full;
374
375 procedure Flush_if_full (W : in out Integer) is
376 begin
377 if W = wsize then
378 Flush (wsize);
379 W := 0;
380 end if;
381 end Flush_if_full;
382
383 ----------------------------------------------------
384 -- Reproduction of sequences in the output slide. --
385 ----------------------------------------------------
386
387 -- Internal:
388
389 procedure Adjust_to_Slide (
390 source : in out Integer;
391 remain : in out Natural;
392 part : out Integer;
393 index : Integer)
394 is
395 pragma Inline (Adjust_to_Slide);
396 begin
397 source := source mod wsize;
398 -- source and index are now in 0 .. WSize-1
399 if source > index then
400 part := wsize - source;
401 else
402 part := wsize - index;
403 end if;
404 -- NB: part is in 1..WSize (part cannot be 0)
405 if part > remain then
406 part := remain;
407 end if;
408 -- Now part <= remain
409 remain := remain - part;
410 -- NB: remain cannot be < 0
411 end Adjust_to_Slide;
412
413 procedure Copy_range (source, index : in out Natural; amount : Positive) is
414 pragma Inline (Copy_range);
415 begin
416 if full_trace then
417 Ada.Text_IO.Put (
418 "(Copy_range: source=" & Integer'Image (source) &
419 " index=" & Integer'Image (index) &
420 " amount=" & Integer'Image (amount));
421 end if;
422 if abs (index - source) < amount then
423 if full_trace and then source < index then
424 Ada.Text_IO.Put (
425 "; replicates" &
426 Integer'Image (amount) & " /" & Integer'Image (index - source) &
427 " )"
428 );
429 -- ...times the range source..index-1
430 end if;
431 -- if source >= index, the effect of copy is just like the non-overlapping case
432 for count in reverse 1 .. amount loop
433 UnZ_Glob.slide (index) := UnZ_Glob.slide (source);
434 index := index + 1;
435 source := source + 1;
436 end loop;
437 else -- non-overlapping -> copy slice
438 UnZ_Glob.slide (index .. index + amount - 1) :=
439 UnZ_Glob.slide (source .. source + amount - 1);
440 index := index + amount;
441 source := source + amount;
442 end if;
443 if full_trace then
444 Ada.Text_IO.Put (')');
445 end if;
446 end Copy_range;
447
448 -- The copying routines:
449
450 procedure Copy (distance, copy_length : Natural; index : in out Natural) is
451 source, part, remain : Integer;
452 begin
453 if some_trace then
454 Ada.Text_IO.Put_Line (LZ77_dump, "DLE" & Integer'Image (distance) & Integer'Image (copy_length));
455 end if;
456 source := index - distance;
457 remain := copy_length;
458 loop
459 Adjust_to_Slide (source, remain, part, index);
460 Copy_range (source, index, part);
461 Flush_if_full (index);
462 exit when remain = 0;
463 end loop;
464 end Copy;
465
466 procedure Copy_or_zero (
467 distance, length : Natural;
468 index : in out Natural;
469 unflushed : in out Boolean)
470 is
471 source, part, remain : Integer;
472 begin
473 source := index - distance;
474 remain := length;
475 loop
476 Adjust_to_Slide (source, remain, part, index);
477 if unflushed and then index <= source then
478 UnZ_Glob.slide (index .. index + part - 1) := (others => 0);
479 index := index + part;
480 source := source + part;
481 else
482 Copy_range (source, index, part);
483 end if;
484 Flush_if_full (index, unflushed);
485 exit when remain = 0;
486 end loop;
487 end Copy_or_zero;
488
489 procedure Delete_output is -- an error has occured (bad compressed data)
490 begin
491 if no_trace then -- if there is a trace, we are debugging
492 case write_mode is -- and want to keep the malformed file
493 when write_to_binary_file =>
494 Ada.Streams.Stream_IO.Delete (UnZ_IO.out_bin_file);
495 when write_to_text_file =>
496 Ada.Text_IO.Delete (UnZ_IO.out_txt_file);
497 when write_to_memory | write_to_stream | just_test =>
498 null; -- Nothing to delete!
499 end case;
500 end if;
501 end Delete_output;
502
503 end UnZ_IO;
504
505 procedure Init_Decryption (password_for_keys : String; crc_check : Unsigned_32) is
506 c : Zip.Byte := 0;
507 t : Unsigned_32;
508 begin
509 -- Step 1 - Initializing the encryption keys
510 Init_Keys (local_crypto_pack, password_for_keys);
511 -- Step 2 - Decrypting the encryption header. 11 bytes are random,
512 -- just to shuffle the keys, 1 byte is from the CRC value.
513 Set_Mode (local_crypto_pack, encrypted);
514 for i in 1 .. 12 loop
515 UnZ_IO.Read_Byte_no_Decrypt (c);
516 Decode (local_crypto_pack, c);
517 end loop;
518 t := Zip_Streams.Calendar.Convert (hint.file_timedate);
519 -- Last byte used to check password; 1/256 probability of success with any password!
520 if c /= Zip.Byte (Shift_Right (crc_check, 24)) and not
521 -- Dec. 2012. This is a feature of Info-Zip (crypt.c), not of PKWARE.
522 -- Since CRC is only known at the end of a one-way stream
523 -- compression, and cannot be written back, they are using a byte of
524 -- the time stamp instead. This is NOT documented in PKWARE's appnote.txt v.6.3.3.
525 (data_descriptor_after_data and c = Zip.Byte (Shift_Right (t, 8) and 16#FF#))
526 then
527 raise UnZip.Wrong_password;
528 end if;
529 end Init_Decryption;
530
531 package body UnZ_Meth is
532
533 --------[ Method: Unshrink ]--------
534
535 -- Original in Pascal written by Christian Ghisler.
536
537 Initial_Code_Size : constant := 9;
538 Maximum_Code_Size : constant := 13;
539 Max_Code : constant := 2 ** Maximum_Code_Size;
540 Max_Stack : constant := 2 ** Maximum_Code_Size;
541
542 -- Rest of slide=write buffer =766 bytes
543
544 Write_Max : constant := wsize - 3 * (Max_Code - 256) - Max_Stack - 2;
545
546 Next_Free : Integer; -- Next free code in trie
547 Write_Ptr : Integer; -- Pointer to output buffer
548
549 Writebuf : Zip.Byte_Buffer (0 .. Write_Max); -- Write buffer
550
551 procedure Unshrink_Flush is
552 use Zip, Ada.Streams, Ada.Streams.Stream_IO;
553 begin
554 if full_trace then
555 Ada.Text_IO.Put ("[Unshrink_Flush]");
556 end if;
557 begin
558 case write_mode is
559 when write_to_binary_file =>
560 Block_Write (Stream (UnZ_IO.out_bin_file).all, Writebuf (0 .. Write_Ptr - 1));
561 when write_to_text_file =>
562 Zip.Write_as_Text (UnZ_IO.out_txt_file, Writebuf (0 .. Write_Ptr - 1), UnZ_IO.last_char);
563 when write_to_memory =>
564 for I in 0 .. Write_Ptr - 1 loop
565 output_memory_access (UnZ_Glob.uncompressed_index) :=
566 Stream_Element (Writebuf (I));
567 UnZ_Glob.uncompressed_index := UnZ_Glob.uncompressed_index + 1;
568 end loop;
569 when write_to_stream =>
570 Block_Write (output_stream_access.all, Writebuf (0 .. Write_Ptr - 1));
571 when just_test =>
572 null;
573 end case;
574 exception
575 when others =>
576 raise UnZip.Write_Error;
577 end;
578 Zip.CRC_Crypto.Update (UnZ_Glob.crc32val, Writebuf (0 .. Write_Ptr - 1));
579 Process_feedback (Zip_64_Data_Size_Type (Write_Ptr));
580 end Unshrink_Flush;
581
582 procedure UD_Write_Byte (B : Zip.Byte) is
583 begin
584 Writebuf (Write_Ptr) := B;
585 Write_Ptr := Write_Ptr + 1;
586 if Write_Ptr > Write_Max then
587 Unshrink_Flush;
588 Write_Ptr := 0;
589 end if;
590 end UD_Write_Byte;
591
592 procedure Unshrink is
593 S : Zip.Zip_64_Data_Size_Type := UnZ_Glob.uncompsize;
594
595 Last_Incode : Integer;
596 Last_Outcode : Zip.Byte;
597 Code_Size : Integer := Initial_Code_Size; -- Actual code size [9 .. 13]
598 Actual_Max_Code : Integer; -- Max code to be searched for leaf nodes
599 First_Entry : constant := 257;
600 Previous_Code : array (First_Entry .. Max_Code) of Integer;
601 Stored_Literal : array (First_Entry .. Max_Code) of Zip.Byte;
602
603 procedure Clear_Leaf_Nodes is
604 Is_Leaf : array (First_Entry .. Max_Code) of Boolean := (others => True);
605 Pc : Integer; -- Previous code
606 begin
607 if full_trace then
608 Ada.Text_IO.Put ("[Clear leaf nodes @ pos" &
609 Zip.Zip_64_Data_Size_Type'Image (UnZ_Glob.uncompsize - S) &
610 "; old Next_Free =" & Integer'Image (Next_Free));
611 end if;
612 for I in First_Entry .. Actual_Max_Code loop
613 Pc := Previous_Code (I);
614 if Pc > 256 then
615 -- Pc is in a tree as well
616 Is_Leaf (Pc) := False;
617 end if;
618 end loop;
619
620 -- Build new free list
621 Pc := -1;
622 Next_Free := -1;
623 for I in First_Entry .. Actual_Max_Code loop
624 -- Either free before, or marked now as leaf
625 if Previous_Code (I) < 0 or Is_Leaf (I) then
626 -- Link last item to this item
627 if Pc = -1 then
628 Next_Free := I;
629 else
630 -- Next free node from Pc is I.
631 Previous_Code (Pc) := -I;
632 end if;
633 Pc := I;
634 end if;
635 end loop;
636
637 if Pc /= -1 then
638 -- Last (old or new) free node points to the first "never used".
639 Previous_Code (Pc) := -(Actual_Max_Code + 1);
640 end if;
641 if Next_Free = -1 then
642 -- Unlikely but possible case:
643 -- - no previously free or leaf node found, or
644 -- - table clearing is ordered when the table is still empty.
645 Next_Free := Actual_Max_Code + 1;
646 end if;
647
648 if full_trace then
649 Ada.Text_IO.Put ("; new Next_Free =" & Integer'Image (Next_Free) & ']');
650 end if;
651 end Clear_Leaf_Nodes;
652
653 procedure Attempt_Table_Increase is
654 Candidate : constant Integer := Next_Free;
655 begin
656 if Candidate > Max_Code then
657 -- This case is supported by PKZip's LZW variant.
658 -- Table clearing is done only on a special command.
659 if some_trace then
660 Ada.Text_IO.Put ("[Table is full]");
661 end if;
662 else
663 if Candidate not in Previous_Code'Range then
664 raise Zip.Archive_corrupted with "Wrong LZW (Shrink) index";
665 end if;
666 Next_Free := -Previous_Code (Candidate);
667 Actual_Max_Code := Integer'Max (Actual_Max_Code, Next_Free - 1);
668
669 -- Next node in free list
670 Previous_Code (Candidate) := Last_Incode;
671 Stored_Literal (Candidate) := Last_Outcode;
672 end if;
673 end Attempt_Table_Increase;
674
675 Incode : Integer; -- Code read in
676 New_Code : Integer; -- Save new normal code read
677 Stack : Zip.Byte_Buffer (0 .. Max_Stack); -- Stack for output
678 Stack_Ptr : Integer := Max_Stack;
679
680 -- PKZip's Shrink is a variant of the LZW algorithm in that the
681 -- compressor controls the code increase and the table clearing.
682 -- See appnote.txt, section 5.1.
683 Special_Code : constant := 256;
684 Code_for_increasing_code_size : constant := 1;
685 Code_for_clearing_table : constant := 2;
686
687 procedure Read_Code is
688 pragma Inline (Read_Code);
689 begin
690 Incode := UnZ_IO.Bit_buffer.Read_and_dump (Code_Size);
691 end Read_Code;
692
693 begin
694 -- Initialize free codes list
695 for I in Previous_Code'Range loop
696 Previous_Code (I) := -(I + 1);
697 end loop;
698 --
699 Stored_Literal := (others => 0);
700 Stack := (others => 0);
701 Writebuf := (others => 0);
702
703 if UnZ_Glob.compsize = Zip.Zip_64_Data_Size_Type'Last then
704 -- Compressed Size was not in header!
705 raise UnZip.Not_supported;
706 elsif UnZ_Glob.uncompsize = 0 then
707 return; -- compression of a 0-file with Shrink.pas
708 end if;
709
710 Next_Free := First_Entry;
711 Actual_Max_Code := First_Entry - 1;
712 Write_Ptr := 0;
713
714 Read_Code;
715 Last_Incode := Incode;
716 if Incode not in 0 .. 255 then
717 raise Zip.Archive_corrupted with "Wrong LZW (Shrink) 1st byte; must be a literal";
718 end if;
719 Last_Outcode := Zip.Byte (Incode);
720 UD_Write_Byte (Last_Outcode);
721 S := S - 1;
722
723 Main_Unshrink_Loop :
724 while S > 0 and then not Zip_EOF loop
725 Read_Code;
726 if Incode = Special_Code then -- Code = 256
727 Read_Code;
728 case Incode is
729 when Code_for_increasing_code_size =>
730 Code_Size := Code_Size + 1;
731 if some_trace then
732 Ada.Text_IO.Put (
733 "[Increment LZW code size to" & Integer'Image (Code_Size) &
734 " bits @ pos" & Zip.Zip_64_Data_Size_Type'Image (UnZ_Glob.uncompsize - S) & ']'
735 );
736 end if;
737 if Code_Size > Maximum_Code_Size then
738 raise Zip.Archive_corrupted with "Wrong LZW (Shrink) code size";
739 end if;
740 when Code_for_clearing_table =>
741 Clear_Leaf_Nodes;
742 when others =>
743 raise Zip.Archive_corrupted with
744 "Wrong LZW (Shrink) special code" & Integer'Image (Incode);
745 end case;
746 else -- Normal code (either a literal (< 256), or a tree node (> 256))
747 New_Code := Incode;
748 if Incode < 256 then -- Literal (simple character)
749 Last_Outcode := Zip.Byte (Incode);
750 UD_Write_Byte (Last_Outcode);
751 S := S - 1;
752 else -- Tree node (code > 256)
753 if Previous_Code (Incode) < 0 then
754 -- First node is orphan (parent is a free node).
755 if full_trace then
756 Ada.Text_IO.Put ("[ Node from stream is orphan ]");
757 end if;
758 Stack (Stack_Ptr) := Last_Outcode;
759 Stack_Ptr := Stack_Ptr - 1;
760 Incode := Last_Incode;
761 end if;
762 while Incode > 256 loop
763 if Stack_Ptr < Stack'First then
764 raise Zip.Archive_corrupted with "LZW (Shrink): String stack exhausted";
765 end if;
766 if Incode > Max_Code then
767 raise Zip.Archive_corrupted with "LZW (Shrink): Incode out of range";
768 end if;
769 if Previous_Code (Incode) < 0 then
770 -- Linked node is orphan (parent is a free node).
771 -- This rare case appears on some data, compressed only by PKZIP.
772 -- The last PKZIP version known to us that is able to compress
773 -- with the Shrink algorithm is PKZIP v.1.10, 1990-03-15.
774 if some_trace then
775 Ada.Text_IO.Put ("[ Linked node is orphan ]");
776 end if;
777 Stack (Stack_Ptr) := Last_Outcode;
778 Incode := Last_Incode;
779 else
780 Stack (Stack_Ptr) := Stored_Literal (Incode);
781 Incode := Previous_Code (Incode);
782 end if;
783 Stack_Ptr := Stack_Ptr - 1;
784 end loop;
785 -- NB: Incode cannot be negative (orphan case treated above).
786 -- It is <= 256 because of the while loop.
787 -- It is /= 256 because it is set to a Last_Incode value (directly or
788 -- through Previous_Code) which is either in [0 .. 255] or > 256.
789 -- So Incode is in [0 .. 255].
790 Last_Outcode := Zip.Byte (Incode);
791 UD_Write_Byte (Last_Outcode);
792 -- Now we output the string in forward order.
793 for I in Stack_Ptr + 1 .. Max_Stack loop
794 UD_Write_Byte (Stack (I));
795 end loop;
796 S := S - Zip.Zip_64_Data_Size_Type (Max_Stack - Stack_Ptr + 1);
797 Stack_Ptr := Max_Stack;
798 end if;
799 Attempt_Table_Increase;
800 Last_Incode := New_Code;
801 end if;
802 end loop Main_Unshrink_Loop;
803
804 if some_trace then
805 Ada.Text_IO.Put ("[ Unshrink main loop finished ]");
806 end if;
807 Unshrink_Flush;
808 end Unshrink;
809
810 --------[ Method: Unreduce ]--------
811
812 procedure Unreduce (factor : Reduction_factor) is
813
814 -- Original slide limit: 16#4000#
815 DLE_code : constant := 144;
816 subtype Symbol_range is Integer range 0 .. 255;
817 subtype Follower_range is Integer range 0 .. 63; -- Appnote: <= 32 !
818 Followers : array (Symbol_range, Follower_range) of Symbol_range :=
819 (others => (others => 0));
820 Slen : array (Symbol_range) of Follower_range;
821
822 -- Bits taken by (x-1) mod 256:
823 B_Table : constant array (Symbol_range) of Integer :=
824 (0 => 8,
825 1 .. 2 => 1,
826 3 .. 4 => 2,
827 5 .. 8 => 3,
828 9 .. 16 => 4,
829 17 .. 32 => 5,
830 33 .. 64 => 6,
831 65 .. 128 => 7,
832 129 .. 255 => 8);
833
834 procedure LoadFollowers is
835 list_followers : constant Boolean := some_trace;
836 procedure Show_symbol (S : Symbol_range) is
837 begin
838 if S in 32 .. 254 then
839 Ada.Text_IO.Put (Character'Val (S));
840 else
841 Ada.Text_IO.Put ('{' & Symbol_range'Image (S) & '}');
842 end if;
843 end Show_symbol;
844 begin
845 for X in reverse Symbol_range loop
846 Slen (X) := UnZ_IO.Bit_buffer.Read_and_dump (6);
847 if list_followers then
848 Show_symbol (X);
849 Ada.Text_IO.Put (" -> (" & Integer'Image (Slen (X)) & ") ");
850 end if;
851 for I in 0 .. Slen (X) - 1 loop
852 Followers (X, I) := UnZ_IO.Bit_buffer.Read_and_dump (8);
853 if list_followers then
854 Show_symbol (Followers (X, I));
855 end if;
856 end loop;
857 if list_followers then
858 Ada.Text_IO.New_Line;
859 end if;
860 end loop;
861 end LoadFollowers;
862
863 length,
864 char_read,
865 last_char : Integer := 0;
866 -- ^ some := 0 are useless, just to calm down ObjectAda 7.2.2
867 S : Zip.Zip_64_Data_Size_Type := UnZ_Glob.uncompsize;
868 -- number of bytes left to decompress
869 unflushed : Boolean := True;
870 maximum_AND_mask : constant Unsigned_32 := Shift_Left (1, 8 - factor) - 1;
871
872 procedure Out_byte (b : Zip.Byte) is
873 begin
874 S := S - 1;
875 UnZ_Glob.slide (UnZ_Glob.slide_index) := b;
876 UnZ_Glob.slide_index := UnZ_Glob.slide_index + 1;
877 UnZ_IO.Flush_if_full (UnZ_Glob.slide_index, unflushed);
878 end Out_byte;
879
880 V : Unsigned_32 := 0;
881 type State_type is (normal, length_a, length_b, distance);
882 state : State_type := normal;
883
884 begin
885 LoadFollowers;
886
887 while S > 0 and then not Zip_EOF loop
888
889 -- 1/ Probabilistic expansion
890 if Slen (last_char) = 0 then
891 -- follower set is empty for this character
892 char_read := UnZ_IO.Bit_buffer.Read_and_dump (8);
893 elsif UnZ_IO.Bit_buffer.Read_and_dump (1) = 0 then
894 char_read := Followers (
895 last_char,
896 UnZ_IO.Bit_buffer.Read_and_dump (B_Table (Slen (last_char)))
897 );
898 else
899 char_read := UnZ_IO.Bit_buffer.Read_and_dump (8);
900 end if;
901
902 -- 2/ Expand the resulting Zip.Byte into repeated sequences
903 case state is
904
905 when normal =>
906 if char_read = DLE_code then
907 -- >> Next will be a DLE
908 state := length_a;
909 else
910 -- >> A single char
911 Out_byte (Zip.Byte (char_read));
912 end if;
913
914 when length_a =>
915 if char_read = 0 then
916 -- >> DLE_code & 0 -> was just the Zip.Byte coded DLE_code
917 Out_byte (DLE_code);
918 state := normal;
919 else
920 V := Unsigned_32 (char_read);
921 length := Integer (V and maximum_AND_mask);
922 -- The remaining bits of V will be used for the distance
923 if length = Integer (maximum_AND_mask) then
924 state := length_b;
925 -- >> length must be completed before reading distance
926 else
927 state := distance;
928 end if;
929 end if;
930
931 when length_b =>
932 length := length + char_read;
933 state := distance;
934
935 when distance =>
936 length := length + 3;
937 S := S - Zip.Zip_64_Data_Size_Type (length);
938
939 UnZ_IO.Copy_or_zero (
940 distance => char_read + 1 + Integer (Shift_Right (V, 8 - factor) * 2**8),
941 length => length,
942 index => UnZ_Glob.slide_index,
943 unflushed => unflushed
944 );
945 state := normal;
946
947 end case;
948
949 last_char := char_read; -- store character for next iteration
950 end loop;
951
952 UnZ_IO.Flush (UnZ_Glob.slide_index);
953 end Unreduce;
954
955 --------[ Method: Explode ]--------
956
957 -- C code by info-zip group, translated to Pascal by Christian Ghisler
958 -- based on unz51g.zip
959
960 use UnZip.Decompress.Huffman;
961
962 procedure Get_Tree (L : out Length_array) is
963 I, K, J, B : Unsigned_32;
964 N : constant Unsigned_32 := L'Length;
965 L_Idx : Integer := L'First;
966 begin
967 if full_trace then
968 Ada.Text_IO.Put_Line ("Begin UnZ_Expl.Get_tree");
969 end if;
970
971 I := Unsigned_32 (UnZ_IO.Read_Byte_Decrypted) + 1;
972 K := 0;
973
974 loop
975 J := Unsigned_32 (UnZ_IO.Read_Byte_Decrypted);
976 B := (J and 16#0F#) + 1;
977 J := (J and 16#F0#) / 16 + 1;
978 if K + J > N then
979 raise Zip.Archive_corrupted;
980 end if;
981
982 loop
983 L (L_Idx) := Natural (B);
984 L_Idx := L_Idx + 1;
985 K := K + 1;
986 J := J - 1;
987 exit when J = 0;
988 end loop;
989
990 I := I - 1;
991 exit when I = 0;
992 end loop;
993
994 if K /= N then
995 raise Zip.Archive_corrupted;
996 end if;
997
998 if full_trace then
999 Ada.Text_IO.Put_Line ("End UnZ_Expl.Get_tree");
1000 end if;
1001 end Get_Tree;
1002
1003 procedure Explode_Lit ( -- method with 3 trees
1004 Needed : Integer;
1005 Tb, Tl, Td : p_Table_list;
1006 Bb, Bl, Bd : Integer
1007 )
1008 is
1009 S : Zip.Zip_64_Data_Size_Type;
1010 E, N, D : Integer;
1011
1012 W : Integer := 0;
1013 Ct : p_HufT_table; -- current table
1014 Ci : Natural; -- current index
1015 unflushed : Boolean := True; -- true while slide not yet unflushed
1016
1017 begin
1018 if full_trace then
1019 Ada.Text_IO.Put_Line ("Begin Explode_lit");
1020 end if;
1021
1022 UnZ_IO.Bit_buffer.Init;
1023
1024 S := UnZ_Glob.uncompsize;
1025 while S > 0 and not Zip_EOF loop
1026 if UnZ_IO.Bit_buffer.Read_and_dump (1) /= 0 then -- 1: Literal
1027 S := S - 1;
1028 Ct := Tb.table;
1029 Ci := UnZ_IO.Bit_buffer.Read_inverted (Bb);
1030
1031 loop
1032 E := Ct (Ci).extra_bits;
1033 exit when E <= 16;
1034
1035 if E = invalid then
1036 raise Zip.Archive_corrupted;
1037 end if;
1038
1039 UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1040 E := E - 16;
1041 Ct := Ct (Ci).next_table;
1042 Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
1043 end loop;
1044
1045 UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1046 UnZ_Glob.slide (W) := Zip.Byte (Ct (Ci).n);
1047 W := W + 1;
1048 UnZ_IO.Flush_if_full (W, unflushed);
1049
1050 else -- 0: Copy
1051 D := UnZ_IO.Bit_buffer.Read_and_dump (Needed);
1052 Ct := Td.table;
1053 Ci := UnZ_IO.Bit_buffer.Read_inverted (Bd);
1054
1055 loop
1056 E := Ct (Ci).extra_bits;
1057 exit when E <= 16;
1058
1059 if E = invalid then
1060 raise Zip.Archive_corrupted;
1061 end if;
1062
1063 UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1064 E := E - 16;
1065 Ct := Ct (Ci).next_table;
1066 Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
1067 end loop;
1068
1069 UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1070 D := D + Ct (Ci).n;
1071
1072 Ct := Tl.table;
1073 Ci := UnZ_IO.Bit_buffer.Read_inverted (Bl);
1074
1075 loop
1076 E := Ct (Ci).extra_bits;
1077 exit when E <= 16;
1078
1079 if E = invalid then
1080 raise Zip.Archive_corrupted;
1081 end if;
1082
1083 UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1084 E := E - 16;
1085 Ct := Ct (Ci).next_table;
1086 Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
1087 end loop;
1088
1089 UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1090
1091 N := Ct (Ci).n;
1092 if E /= 0 then
1093 N := N + UnZ_IO.Bit_buffer.Read_and_dump (8);
1094 end if;
1095 S := S - Zip.Zip_64_Data_Size_Type (N);
1096
1097 UnZ_IO.Copy_or_zero (
1098 distance => D,
1099 length => N,
1100 index => W,
1101 unflushed => unflushed
1102 );
1103
1104 end if;
1105 end loop;
1106
1107 UnZ_IO.Flush (W);
1108 if Zip_EOF then
1109 raise Zip.Archive_corrupted with "End of stream reached";
1110 end if;
1111
1112 if full_trace then
1113 Ada.Text_IO.Put_Line ("End Explode_lit");
1114 end if;
1115 end Explode_Lit;
1116
1117 procedure Explode_Nolit ( -- method with 2 trees
1118 Needed : Integer;
1119 Tl, Td : p_Table_list;
1120 Bl, Bd : Integer
1121 )
1122 is
1123 S : Zip.Zip_64_Data_Size_Type;
1124 E, N, D : Integer;
1125 W : Integer := 0;
1126 Ct : p_HufT_table; -- current table
1127 Ci : Natural; -- current index
1128 unflushed : Boolean := True; -- true while slide not yet unflushed
1129
1130 begin
1131 if full_trace then
1132 Ada.Text_IO.Put_Line ("Begin Explode_nolit");
1133 end if;
1134
1135 UnZ_IO.Bit_buffer.Init;
1136 S := UnZ_Glob.uncompsize;
1137 while S > 0 and not Zip_EOF loop
1138 if UnZ_IO.Bit_buffer.Read_and_dump (1) /= 0 then -- 1: Literal
1139 S := S - 1;
1140 UnZ_Glob.slide (W) :=
1141 Zip.Byte (UnZ_IO.Bit_buffer.Read_and_dump (8));
1142 W := W + 1;
1143 UnZ_IO.Flush_if_full (W, unflushed);
1144 else -- 0: Copy
1145 D := UnZ_IO.Bit_buffer.Read_and_dump (Needed);
1146 Ct := Td.table;
1147 Ci := UnZ_IO.Bit_buffer.Read_inverted (Bd);
1148
1149 loop
1150 E := Ct (Ci).extra_bits;
1151 exit when E <= 16;
1152
1153 if E = invalid then
1154 raise Zip.Archive_corrupted;
1155 end if;
1156
1157 UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1158 E := E - 16;
1159 Ct := Ct (Ci).next_table;
1160 Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
1161 end loop;
1162
1163 UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1164
1165 D := D + Ct (Ci).n;
1166 Ct := Tl.table;
1167 Ci := UnZ_IO.Bit_buffer.Read_inverted (Bl);
1168
1169 loop
1170 E := Ct (Ci).extra_bits;
1171 exit when E <= 16;
1172
1173 if E = invalid then
1174 raise Zip.Archive_corrupted;
1175 end if;
1176
1177 UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1178 E := E - 16;
1179 Ct := Ct (Ci).next_table;
1180 Ci := UnZ_IO.Bit_buffer.Read_inverted (E);
1181 end loop;
1182
1183 UnZ_IO.Bit_buffer.Dump (Ct (Ci).bits);
1184
1185 N := Ct (Ci).n;
1186 if E /= 0 then
1187 N := N + UnZ_IO.Bit_buffer.Read_and_dump (8);
1188 end if;
1189 S := S - Zip.Zip_64_Data_Size_Type (N);
1190
1191 UnZ_IO.Copy_or_zero (
1192 distance => D,
1193 length => N,
1194 index => W,
1195 unflushed => unflushed
1196 );
1197
1198 end if;
1199 end loop;
1200
1201 UnZ_IO.Flush (W);
1202 if Zip_EOF then
1203 raise Zip.Archive_corrupted with "End of stream reached";
1204 end if;
1205
1206 if full_trace then
1207 Ada.Text_IO.Put_Line ("End Explode_nolit");
1208 end if;
1209
1210 end Explode_Nolit;
1211
1212 procedure Explode (literal_tree, slide_8_KB : Boolean) is
1213
1214 Tb, Tl, Td : p_Table_list;
1215 Bb, Bl, Bd : Integer;
1216 L : Length_array (0 .. 255);
1217 huft_incomplete : Boolean;
1218
1219 cp_length_2_trees :
1220 constant Length_array (0 .. 63) :=
1221 (2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17,
1222 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34,
1223 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51,
1224 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65);
1225
1226 cp_length_3_trees :
1227 constant Length_array (0 .. 63) :=
1228 (3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18,
1229 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35,
1230 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52,
1231 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66);
1232
1233 cp_dist_4KB :
1234 constant Length_array (0 .. 63) :=
1235 (1, 65, 129, 193, 257, 321, 385, 449, 513, 577, 641, 705,
1236 769, 833, 897, 961, 1025, 1089, 1153, 1217, 1281, 1345, 1409, 1473,
1237 1537, 1601, 1665, 1729, 1793, 1857, 1921, 1985, 2049, 2113, 2177,
1238 2241, 2305, 2369, 2433, 2497, 2561, 2625, 2689, 2753, 2817, 2881,
1239 2945, 3009, 3073, 3137, 3201, 3265, 3329, 3393, 3457, 3521, 3585,
1240 3649, 3713, 3777, 3841, 3905, 3969, 4033);
1241
1242 cp_dist_8KB :
1243 constant Length_array (0 .. 63) :=
1244 (1, 129, 257, 385, 513, 641, 769, 897, 1025, 1153, 1281,
1245 1409, 1537, 1665, 1793, 1921, 2049, 2177, 2305, 2433, 2561, 2689,
1246 2817, 2945, 3073, 3201, 3329, 3457, 3585, 3713, 3841, 3969, 4097,
1247 4225, 4353, 4481, 4609, 4737, 4865, 4993, 5121, 5249, 5377, 5505,
1248 5633, 5761, 5889, 6017, 6145, 6273, 6401, 6529, 6657, 6785, 6913,
1249 7041, 7169, 7297, 7425, 7553, 7681, 7809, 7937, 8065);
1250
1251 extra :
1252 constant Length_array (0 .. 63) := (0 .. 62 => 0, 63 => 8);
1253
1254 begin
1255 Bl := 7;
1256 if UnZ_Glob.compsize > 200000 then
1257 Bd := 8;
1258 else
1259 Bd := 7;
1260 end if;
1261
1262 if literal_tree then
1263 Bb := 9;
1264 Get_Tree (L);
1265 begin
1266 HufT_build (L, 256, empty, empty, Tb, Bb, huft_incomplete);
1267 if huft_incomplete then
1268 HufT_free (Tb);
1269 raise Zip.Archive_corrupted;
1270 end if;
1271 exception
1272 when others =>
1273 raise Zip.Archive_corrupted;
1274 end;
1275
1276 begin
1277 Get_Tree (L (0 .. 63));
1278 exception
1279 when others =>
1280 HufT_free (Tb);
1281 raise Zip.Archive_corrupted;
1282 end;
1283
1284 begin
1285 HufT_build (
1286 L (0 .. 63), 0, cp_length_3_trees, extra, Tl, Bl, huft_incomplete
1287 );
1288 if huft_incomplete then
1289 HufT_free (Tl);
1290 HufT_free (Tb);
1291 raise Zip.Archive_corrupted;
1292 end if;
1293 exception
1294 when others =>
1295 HufT_free (Tb);
1296 raise Zip.Archive_corrupted;
1297 end;
1298
1299 begin
1300 Get_Tree (L (0 .. 63));
1301 exception
1302 when others =>
1303 HufT_free (Tb);
1304 HufT_free (Tl);
1305 raise Zip.Archive_corrupted;
1306 end;
1307
1308 begin
1309 if slide_8_KB then
1310 HufT_build (
1311 L (0 .. 63), 0, cp_dist_8KB, extra, Td, Bd, huft_incomplete
1312 );
1313 if huft_incomplete then
1314 HufT_free (Td);
1315 HufT_free (Tl);
1316 HufT_free (Tb);
1317 raise Zip.Archive_corrupted;
1318 end if;
1319 -- Exploding, method: 8k slide, 3 trees
1320 Explode_Lit (7, Tb, Tl, Td, Bb, Bl, Bd);
1321 else
1322 HufT_build (
1323 L (0 .. 63), 0, cp_dist_4KB, extra, Td, Bd, huft_incomplete
1324 );
1325 if huft_incomplete then
1326 HufT_free (Td);
1327 HufT_free (Tl);
1328 HufT_free (Tb);
1329 raise Zip.Archive_corrupted;
1330 end if;
1331 -- Exploding, method: 4k slide, 3 trees
1332 Explode_Lit (6, Tb, Tl, Td, Bb, Bl, Bd);
1333 end if;
1334 exception
1335 when others =>
1336 HufT_free (Tl);
1337 HufT_free (Tb);
1338 raise Zip.Archive_corrupted;
1339 end;
1340 HufT_free (Td);
1341 HufT_free (Tl);
1342 HufT_free (Tb);
1343
1344 else -- No literal tree
1345
1346 begin
1347 Get_Tree (L (0 .. 63));
1348 exception
1349 when others =>
1350 raise Zip.Archive_corrupted;
1351 end;
1352
1353 begin
1354 HufT_build (
1355 L (0 .. 63), 0, cp_length_2_trees, extra, Tl, Bl, huft_incomplete
1356 );
1357 if huft_incomplete then
1358 HufT_free (Tl);
1359 raise Zip.Archive_corrupted;
1360 end if;
1361 exception
1362 when others =>
1363 raise Zip.Archive_corrupted;
1364 end;
1365
1366 begin
1367 Get_Tree (L (0 .. 63));
1368 exception
1369 when others =>
1370 HufT_free (Tl);
1371 raise Zip.Archive_corrupted;
1372 end;
1373
1374 begin
1375 if slide_8_KB then
1376 HufT_build (
1377 L (0 .. 63), 0, cp_dist_8KB, extra, Td, Bd, huft_incomplete
1378 );
1379 if huft_incomplete then
1380 HufT_free (Td);
1381 HufT_free (Tl);
1382 raise Zip.Archive_corrupted;
1383 end if;
1384 -- Exploding, method: 8k slide, 2 trees
1385 Explode_Nolit (7, Tl, Td, Bl, Bd);
1386 else
1387 HufT_build (
1388 L (0 .. 63), 0, cp_dist_4KB, extra, Td, Bd, huft_incomplete
1389 );
1390 if huft_incomplete then
1391 HufT_free (Td);
1392 HufT_free (Tl);
1393 raise Zip.Archive_corrupted;
1394 end if;
1395 -- Exploding, method: 4k slide, 2 trees
1396 Explode_Nolit (6, Tl, Td, Bl, Bd);
1397 end if;
1398 exception
1399 when others =>
1400 HufT_free (Tl);
1401 raise Zip.Archive_corrupted;
1402 end;
1403 HufT_free (Td);
1404 HufT_free (Tl);
1405 end if;
1406
1407 end Explode;
1408
1409 --------[ Method: Copy stored ]--------
1410
1411 procedure Copy_stored is
1412 size : constant Zip.Zip_64_Data_Size_Type := UnZ_Glob.compsize;
1413 read_in, absorbed : Zip.Zip_64_Data_Size_Type;
1414 begin
1415 absorbed := 0;
1416 if Get_Mode (local_crypto_pack) = encrypted then
1417 absorbed := 12;
1418 end if;
1419 while absorbed < size loop
1420 read_in := size - absorbed;
1421 if read_in > wsize then
1422 read_in := wsize;
1423 end if;
1424 begin
1425 for I in 0 .. read_in - 1 loop
1426 UnZ_Glob.slide (Natural (I)) := UnZ_IO.Read_Byte_Decrypted;
1427 end loop;
1428 exception
1429 when others =>
1430 raise Zip.Archive_corrupted with
1431 "End of stream reached (format: Store)";
1432 end;
1433 begin
1434 UnZ_IO.Flush (Natural (read_in)); -- Takes care of CRC too
1435 exception
1436 when User_abort =>
1437 raise;
1438 when others =>
1439 raise UnZip.Write_Error;
1440 end;
1441 absorbed := absorbed + read_in;
1442 end loop;
1443 end Copy_stored;
1444
1445 --------[ Method: Inflate ]--------
1446
1447 lt_count, dl_count,
1448 lt_count_0, dl_count_0,
1449 lt_count_dyn, dl_count_dyn,
1450 lt_count_fix, dl_count_fix : Long_Integer := 0; -- Statistics of LZ codes per block
1451
1452 procedure Inflate_Codes (Tl, Td : p_Table_list; Bl, Bd : Integer) is
1453 CT : p_HufT_table; -- current table
1454 CT_idx : Natural; -- current table's index
1455 length : Natural;
1456 E : Integer; -- table entry flag/number of extra bits
1457 W : Integer := UnZ_Glob.slide_index; -- more local variable for slide index
1458 literal : Zip.Byte;
1459 begin
1460 if some_trace then
1461 lt_count_0 := lt_count;
1462 dl_count_0 := dl_count;
1463 Ada.Text_IO.Put_Line ("Begin Inflate_codes");
1464 end if;
1465
1466 -- inflate the coded data
1467 main_loop :
1468 while not Zip_EOF loop
1469 if Tl = null then
1470 raise Zip.Archive_corrupted with
1471 "Null table list (on data decoding, Huffman tree for literals or LZ lengths)";
1472 end if;
1473 CT := Tl.table;
1474 CT_idx := UnZ_IO.Bit_buffer.Read (Bl);
1475 loop
1476 E := CT (CT_idx).extra_bits;
1477 exit when E <= 16;
1478 if E = invalid then
1479 raise Zip.Archive_corrupted;
1480 end if;
1481
1482 -- then it's a literal
1483 UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
1484 E := E - 16;
1485 CT := CT (CT_idx).next_table;
1486 CT_idx := UnZ_IO.Bit_buffer.Read (E);
1487 end loop;
1488
1489 UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
1490
1491 case E is
1492 when 16 => -- CT(CT_idx).N is a Literal (code 0 .. 255)
1493 literal := Zip.Byte (CT (CT_idx).n);
1494 if some_trace then
1495 lt_count := lt_count + 1;
1496 Ada.Text_IO.Put (LZ77_dump, "Lit" & Zip.Byte'Image (literal));
1497 if literal in 32 .. 126 then
1498 Ada.Text_IO.Put (LZ77_dump, " '" & Character'Val (literal) & ''');
1499 end if;
1500 Ada.Text_IO.New_Line (LZ77_dump);
1501 end if;
1502 UnZ_Glob.slide (W) := literal;
1503 W := W + 1;
1504 UnZ_IO.Flush_if_full (W);
1505
1506 when 15 => -- End of block (EOB, code 256)
1507 if full_trace then
1508 Ada.Text_IO.Put_Line ("Exit Inflate_codes, e=15 -> EOB");
1509 end if;
1510 exit main_loop;
1511
1512 when others => -- We have a length/distance code
1513 if some_trace then
1514 dl_count := dl_count + 1;
1515 end if;
1516 -- Get length of block to copy:
1517 length := CT (CT_idx).n + UnZ_IO.Bit_buffer.Read_and_dump (E);
1518
1519 -- Decode distance of block to copy:
1520 if Td = null then
1521 raise Zip.Archive_corrupted with
1522 "Null table list (on data decoding, Huffman tree for LZ distances)";
1523 end if;
1524 CT := Td.table;
1525 CT_idx := UnZ_IO.Bit_buffer.Read (Bd);
1526 loop
1527 E := CT (CT_idx).extra_bits;
1528 exit when E <= 16;
1529 if E = invalid then
1530 raise Zip.Archive_corrupted;
1531 end if;
1532 UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
1533 E := E - 16;
1534 CT := CT (CT_idx).next_table;
1535 CT_idx := UnZ_IO.Bit_buffer.Read (E);
1536 end loop;
1537 UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
1538 UnZ_IO.Copy (
1539 distance => CT (CT_idx).n + UnZ_IO.Bit_buffer.Read_and_dump (E),
1540 copy_length => length,
1541 index => W
1542 );
1543 end case;
1544 end loop main_loop;
1545
1546 UnZ_Glob.slide_index := W;
1547
1548 if some_trace then
1549 Ada.Text_IO.Put_Line ("End Inflate_codes; " &
1550 Long_Integer'Image (lt_count - lt_count_0) & " literals," &
1551 Long_Integer'Image (dl_count - dl_count_0) & " DL codes," &
1552 Long_Integer'Image (dl_count + lt_count - lt_count_0 - dl_count_0) & " in total");
1553 end if;
1554 end Inflate_Codes;
1555
1556 procedure Inflate_stored_block is -- Actually, nothing to inflate
1557 N : Integer;
1558 begin
1559 UnZ_IO.Bit_buffer.Dump_to_byte_boundary;
1560 -- Get the block length and its complement
1561 N := UnZ_IO.Bit_buffer.Read_and_dump (16);
1562 if some_trace then
1563 Ada.Text_IO.Put_Line ("Begin Inflate_stored_block, bytes stored: " & Integer'Image (N));
1564 end if;
1565 if N /= Integer (
1566 (not UnZ_IO.Bit_buffer.Read_and_dump_U32 (16))
1567 and 16#ffff#)
1568 then
1569 raise Zip.Archive_corrupted;
1570 end if;
1571 while N > 0 and then not Zip_EOF loop
1572 -- Read and output the non-compressed data
1573 N := N - 1;
1574 UnZ_Glob.slide (UnZ_Glob.slide_index) :=
1575 Zip.Byte (UnZ_IO.Bit_buffer.Read_and_dump (8));
1576 UnZ_Glob.slide_index := UnZ_Glob.slide_index + 1;
1577 UnZ_IO.Flush_if_full (UnZ_Glob.slide_index);
1578 end loop;
1579 if some_trace then
1580 Ada.Text_IO.Put_Line ("End Inflate_stored_block");
1581 end if;
1582 end Inflate_stored_block;
1583
1584 -- Copy lengths for literal codes 257..285
1585
1586 copy_lengths_literal : Length_array (0 .. 30) :=
1587 (3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31,
1588 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0);
1589
1590 -- Extra bits for literal codes 257..285
1591
1592 extra_bits_literal : Length_array (0 .. 30) :=
1593 (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2,
1594 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0, invalid, invalid);
1595
1596 -- Copy offsets for distance codes 0..29 (30..31: deflate_e)
1597
1598 copy_offset_distance : constant Length_array (0 .. 31) :=
1599 (1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193,
1600 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145,
1601 8193, 12289, 16385, 24577, 32769, 49153);
1602
1603 -- Extra bits for distance codes
1604
1605 extra_bits_distance : constant Length_array (0 .. 31) :=
1606 (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6,
1607 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14);
1608
1609 max_dist : Integer := 29; -- changed to 31 for deflate_e
1610
1611 length_list_for_fixed_block_literals : constant Length_array (0 .. 287) :=
1612 (0 .. 143 => 8, 144 .. 255 => 9, 256 .. 279 => 7, 280 .. 287 => 8);
1613
1614 procedure Inflate_fixed_block is
1615 Tl, -- literal/length code table
1616 Td : p_Table_list; -- distance code table
1617 Bl, Bd : Integer; -- lookup bits for tl/bd
1618 huft_incomplete : Boolean;
1619 begin
1620 if some_trace then
1621 Ada.Text_IO.Put_Line ("Begin Inflate_fixed_block");
1622 end if;
1623 -- Make a complete, but wrong [why ?] code set (see Appnote: 5.5.2, RFC 1951: 3.2.6)
1624 Bl := 7;
1625 HufT_build (
1626 length_list_for_fixed_block_literals, 257, copy_lengths_literal,
1627 extra_bits_literal, Tl, Bl, huft_incomplete
1628 );
1629 -- Make an incomplete code set (see Appnote: 5.5.2, RFC 1951: 3.2.6)
1630 Bd := 5;
1631 begin
1632 HufT_build (
1633 (0 .. max_dist => 5), 0,
1634 copy_offset_distance, extra_bits_distance,
1635 Td, Bd, huft_incomplete
1636 );
1637 if huft_incomplete then
1638 if full_trace then
1639 Ada.Text_IO.Put_Line (
1640 "td is incomplete, pointer=null: " &
1641 Boolean'Image (Td = null)
1642 );
1643 end if;
1644 end if;
1645 exception
1646 when huft_out_of_memory | huft_error =>
1647 HufT_free (Tl);
1648 raise Zip.Archive_corrupted;
1649 end;
1650 -- Decompress the block's data, until an end-of-block code.
1651 Inflate_Codes (Tl, Td, Bl, Bd);
1652 -- Done with this block, free resources.
1653 HufT_free (Tl);
1654 HufT_free (Td);
1655 if some_trace then
1656 Ada.Text_IO.Put_Line ("End Inflate_fixed_block");
1657 lt_count_fix := lt_count_fix + (lt_count - lt_count_0);
1658 dl_count_fix := dl_count_fix + (dl_count - dl_count_0);
1659 end if;
1660 end Inflate_fixed_block;
1661
1662 bit_order_for_dynamic_block : constant array (0 .. 18) of Natural :=
1663 (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);
1664
1665 procedure Inflate_dynamic_block is
1666
1667 Lbits : constant := 9;
1668 Dbits : constant := 6;
1669
1670 current_length : Natural;
1671 defined, number_of_lengths : Natural;
1672
1673 Tl, -- literal/length code tables
1674 Td : p_Table_list; -- distance code tables
1675
1676 CT : p_HufT_table; -- current table
1677 CT_idx : Natural; -- current table's index
1678
1679 Bl, Bd : Integer; -- lookup bits for tl/bd
1680 Nb : Natural; -- number of bit length codes
1681 Nl : Natural; -- number of literal length codes
1682 Nd : Natural; -- number of distance codes
1683
1684 -- literal/length and distance code lengths
1685 Ll : Length_array (0 .. 288 + 32 - 1) := (others => 0);
1686
1687 huft_incomplete : Boolean;
1688
1689 procedure Repeat_length_code (amount : Natural) is
1690 begin
1691 if defined + amount > number_of_lengths then
1692 raise Zip.Archive_corrupted;
1693 end if;
1694 for c in reverse 1 .. amount loop
1695 Ll (defined) := current_length;
1696 defined := defined + 1;
1697 end loop;
1698 end Repeat_length_code;
1699
1700 begin
1701 if some_trace then
1702 Ada.Text_IO.Put_Line ("Begin Inflate_dynamic_block");
1703 end if;
1704
1705 -- Read in table lengths
1706 Nl := 257 + UnZ_IO.Bit_buffer.Read_and_dump (5);
1707 Nd := 1 + UnZ_IO.Bit_buffer.Read_and_dump (5);
1708 Nb := 4 + UnZ_IO.Bit_buffer.Read_and_dump (4);
1709
1710 if Nl > 288 or else Nd > 32 then
1711 raise Zip.Archive_corrupted;
1712 end if;
1713
1714 -- Read in bit-length-code lengths for decoding the compression structure.
1715 -- The rest, Ll( Bit_Order( Nb .. 18 ) ), is already = 0
1716 for J in 0 .. Nb - 1 loop
1717 Ll (bit_order_for_dynamic_block (J)) := UnZ_IO.Bit_buffer.Read_and_dump (3);
1718 end loop;
1719
1720 -- Build decoding table for trees--single level, 7 bit lookup
1721 Bl := 7;
1722 begin
1723 HufT_build (
1724 Ll (0 .. 18), 19, empty, empty, Tl, Bl, huft_incomplete
1725 );
1726 if huft_incomplete then
1727 HufT_free (Tl);
1728 raise Zip.Archive_corrupted with "Incomplete code set for compression structure";
1729 end if;
1730 exception
1731 when others =>
1732 raise Zip.Archive_corrupted with "Error when building tables for compression structure";
1733 end;
1734
1735 -- Read in the compression structure: literal and distance code lengths
1736 number_of_lengths := Nl + Nd;
1737 defined := 0;
1738 current_length := 0;
1739
1740 while defined < number_of_lengths loop
1741 if Tl = null then
1742 raise Zip.Archive_corrupted with
1743 "Null table list (on compression structure)";
1744 end if;
1745 CT := Tl.table;
1746 CT_idx := UnZ_IO.Bit_buffer.Read (Bl);
1747 UnZ_IO.Bit_buffer.Dump (CT (CT_idx).bits);
1748
1749 case CT (CT_idx).n is
1750 when 0 .. 15 => -- Length of code for symbol of index 'defined', in bits (0..15)
1751 current_length := CT (CT_idx).n;
1752 Ll (defined) := current_length;
1753 defined := defined + 1;
1754 when 16 => -- 16 means: repeat last bit length 3 to 6 times
1755 if defined = 0 then
1756 -- Nothing in the Ll array has been defined so far. Then, current_length is
1757 -- (theoretically) undefined and cannot be repeated.
1758 -- This unspecified case is treated as an error by zlib's inflate.c.
1759 raise Zip.Archive_corrupted with
1760 "Illegal data for compression structure (repeat an undefined code length)";
1761 end if;
1762 Repeat_length_code (3 + UnZ_IO.Bit_buffer.Read_and_dump (2));
1763 when 17 => -- 17 means: the next 3 to 10 symbols' codes have zero bit lengths
1764 current_length := 0;
1765 Repeat_length_code (3 + UnZ_IO.Bit_buffer.Read_and_dump (3));
1766 when 18 => -- 18 means: the next 11 to 138 symbols' codes have zero bit lengths
1767 current_length := 0;
1768 Repeat_length_code (11 + UnZ_IO.Bit_buffer.Read_and_dump (7));
1769 when others => -- Shouldn't occur if this tree is correct
1770 raise Zip.Archive_corrupted with
1771 "Illegal data for compression structure (values should be in the range 0 .. 18): "
1772 & Integer'Image (CT (CT_idx).n);
1773 end case;
1774 end loop;
1775 -- Free the Huffman tree that was used for decoding the compression
1776 -- structure, which is contained now in Ll.
1777 HufT_free (Tl);
1778 if Ll (256) = 0 then
1779 -- No code length for the End-Of-Block symbol, implies infinite stream!
1780 -- This case is unspecified but obviously we must stop here.
1781 raise Zip.Archive_corrupted with "No code length for End-Of-Block symbol #256";
1782 end if;
1783 -- Build the decoding tables for literal/length codes
1784 Bl := Lbits;
1785 begin
1786 HufT_build (
1787 Ll (0 .. Nl - 1), 257,
1788 copy_lengths_literal, extra_bits_literal,
1789 Tl, Bl, huft_incomplete
1790 );
1791 if huft_incomplete then
1792 HufT_free (Tl);
1793 raise Zip.Archive_corrupted with "Incomplete code set for literals/lengths";
1794 end if;
1795 exception
1796 when others =>
1797 raise Zip.Archive_corrupted with "Error when building tables for literals/lengths";
1798 end;
1799 -- Build the decoding tables for distance codes
1800 Bd := Dbits;
1801 begin
1802 HufT_build (
1803 Ll (Nl .. Nl + Nd - 1), 0,
1804 copy_offset_distance, extra_bits_distance,
1805 Td, Bd, huft_incomplete
1806 );
1807 if huft_incomplete then
1808 if deflate_strict then
1809 raise Zip.Archive_corrupted with "Incomplete code set for distances";
1810 elsif some_trace then -- not deflate_strict => don't stop
1811 Ada.Text_IO.Put_Line ("Huffman tree incomplete - PKZIP 1.93a bug workaround");
1812 end if;
1813 end if;
1814 exception
1815 when huft_out_of_memory | huft_error =>
1816 HufT_free (Tl);
1817 raise Zip.Archive_corrupted with "Error when building tables for distances";
1818 end;
1819 -- Decompress the block's data, until an end-of-block code.
1820 Inflate_Codes (Tl, Td, Bl, Bd);
1821 -- Done with this block, free resources.
1822 HufT_free (Tl);
1823 HufT_free (Td);
1824 if some_trace then
1825 Ada.Text_IO.Put_Line ("End Inflate_dynamic_block");
1826 lt_count_dyn := lt_count_dyn + (lt_count - lt_count_0);
1827 dl_count_dyn := dl_count_dyn + (dl_count - dl_count_0);
1828 end if;
1829 end Inflate_dynamic_block;
1830
1831 procedure Inflate_Block (last_block : out Boolean; fix, dyn : in out Long_Integer) is
1832 begin
1833 last_block := Boolean'Val (UnZ_IO.Bit_buffer.Read_and_dump (1));
1834 case UnZ_IO.Bit_buffer.Read_and_dump (2) is -- Block type = 0, 1, 2, 3
1835 when 0 => Inflate_stored_block;
1836 when 1 => Inflate_fixed_block;
1837 fix := fix + 1;
1838 when 2 => Inflate_dynamic_block;
1839 dyn := dyn + 1;
1840 when others => raise Zip.Archive_corrupted with "Inflate: Bad block type (3)";
1841 end case;
1842 end Inflate_Block;
1843
1844 procedure Inflate is
1845 is_last_block : Boolean;
1846 blocks, blocks_fix, blocks_dyn : Long_Integer := 0;
1847 begin
1848 if deflate_e_mode then
1849 copy_lengths_literal (28) := 3; -- instead of 258
1850 extra_bits_literal (28) := 16; -- instead of 0
1851 max_dist := 31;
1852 end if;
1853 loop
1854 blocks := blocks + 1;
1855 Inflate_Block (is_last_block, blocks_fix, blocks_dyn);
1856 exit when is_last_block;
1857 end loop;
1858 UnZ_IO.Flush (UnZ_Glob.slide_index);
1859 UnZ_Glob.slide_index := 0;
1860 if some_trace then
1861 Ada.Text_IO.Put_Line (
1862 "# blocks:" & Long_Integer'Image (blocks) &
1863 "; fixed:" & Long_Integer'Image (blocks_fix) &
1864 "; dynamic:" & Long_Integer'Image (blocks_dyn));
1865 if blocks_fix > 0 then
1866 Ada.Text_IO.Put_Line (
1867 "Averages per fixed block: literals:" & Long_Integer'Image (lt_count_fix / blocks_fix) &
1868 "; DL codes:" & Long_Integer'Image (dl_count_fix / blocks_fix) &
1869 "; all codes:" & Long_Integer'Image ((lt_count_fix + dl_count_fix) / blocks_fix));
1870 end if;
1871 if blocks_dyn > 0 then
1872 Ada.Text_IO.Put_Line (
1873 "Averages per dynamic block: literals:" & Long_Integer'Image (lt_count_dyn / blocks_dyn) &
1874 "; DL codes:" & Long_Integer'Image (dl_count_dyn / blocks_dyn) &
1875 "; all codes:" & Long_Integer'Image ((lt_count_dyn + dl_count_dyn) / blocks_dyn));
1876 end if;
1877 end if;
1878 end Inflate;
1879
1880 procedure Write_Single_Byte (b : Unsigned_8) with Inline is
1881 begin
1882 UnZ_Glob.slide (UnZ_Glob.slide_index) := b;
1883 UnZ_Glob.slide_index := UnZ_Glob.slide_index + 1;
1884 UnZ_IO.Flush_if_full (UnZ_Glob.slide_index);
1885 end Write_Single_Byte;
1886
1887 --------[ Method: BZip2 ]--------
1888
1889 procedure Bunzip2 is
1890 package My_BZip2 is new BZip2.Decoding
1891 (Read_Byte => UnZ_IO.Read_Byte_Decrypted,
1892 Write_Byte => Write_Single_Byte,
1893 check_CRC => False); -- CRC check is already done by UnZ_IO
1894 begin
1895 My_BZip2.Decompress;
1896 UnZ_IO.Flush (UnZ_Glob.slide_index);
1897 exception
1898 when E : My_BZip2.bad_header_magic | My_BZip2.bad_block_magic | My_BZip2.data_error =>
1899 raise Zip.Archive_corrupted with
1900 "BZip2 error: " & Exception_Name (E) & " - " & Exception_Message (E);
1901 when E : My_BZip2.randomized_not_yet_implemented =>
1902 raise UnZip.Unsupported_method with
1903 "BZip2: " & Exception_Name (E) & " - " & Exception_Message (E);
1904 end Bunzip2;
1905
1906 --------[ Method: LZMA ]--------
1907
1908 procedure LZMA_Decode is
1909 package My_LZMA_Decoding is new LZMA.Decoding (UnZ_IO.Read_Byte_Decrypted, Write_Single_Byte);
1910 b3, b4 : Unsigned_8;
1911 begin
1912 b3 := UnZ_IO.Read_Byte_Decrypted; -- LZMA SDK major version (e.g.: 9)
1913 b3 := UnZ_IO.Read_Byte_Decrypted; -- LZMA SDK minor version (e.g.: 20)
1914 b3 := UnZ_IO.Read_Byte_Decrypted; -- LZMA properties size low byte
1915 b4 := UnZ_IO.Read_Byte_Decrypted; -- LZMA properties size high byte
1916 if Natural (b3) + 256 * Natural (b4) /= 5 then
1917 raise Zip.Archive_corrupted with "Unexpected LZMA properties block size";
1918 end if;
1919 My_LZMA_Decoding.Decompress
1920 ((has_size => False, -- Data size is not part of the LZMA header.
1921 given_size => LZMA.Data_Bytes_Count (UnZ_Glob.uncompsize),
1922 marker_expected => explode_slide_8KB_LZMA_EOS, -- End-Of-Stream marker?
1923 fail_on_bad_range_code => True));
1924 UnZ_IO.Flush (UnZ_Glob.slide_index);
1925 exception
1926 when E : My_LZMA_Decoding.LZMA_Error =>
1927 raise Zip.Archive_corrupted with
1928 "LZMA error: " & Exception_Name (E) & " - " & Exception_Message (E);
1929 end LZMA_Decode;
1930
1931 end UnZ_Meth;
1932
1933 procedure Process_descriptor (dd : out Zip.Headers.Data_Descriptor) is
1934 start : Integer;
1935 b : Unsigned_8;
1936 dd_buffer : Zip.Byte_Buffer (1 .. 30);
1937 begin
1938 UnZ_IO.Bit_buffer.Dump_to_byte_boundary;
1939 Set_Mode (local_crypto_pack, clear); -- We are after compressed data, switch off decryption.
1940 b := UnZ_IO.Read_Byte_Decrypted;
1941 if b = 75 then -- 'K' ('P' is before, this is a Java/JAR bug!)
1942 dd_buffer (1) := 80;
1943 dd_buffer (2) := 75;
1944 start := 3;
1945 else
1946 dd_buffer (1) := b; -- hopefully = 80 (will be checked)
1947 start := 2;
1948 end if;
1949 for i in start .. 16 loop
1950 dd_buffer (i) := UnZ_IO.Read_Byte_Decrypted;
1951 end loop;
1952 Zip.Headers.Copy_and_Check (dd_buffer, dd);
1953 exception
1954 when Zip.Headers.bad_data_descriptor =>
1955 raise Zip.Archive_corrupted;
1956 end Process_descriptor;
1957
1958 work_index : Zip_Streams.ZS_Index_Type;
1959 use Zip, UnZ_Meth, Ada.Strings.Unbounded;
1960
1961 begin -- Decompress_Data
1962 if some_trace then
1963 Ada.Text_IO.Create (LZ77_dump, Ada.Text_IO.Out_File, "dump.lz77");
1964 end if;
1965 output_memory_access := null;
1966 -- ^ this is an 'out' parameter, we have to set it anyway
1967 case write_mode is
1968 when write_to_binary_file =>
1969 Ada.Streams.Stream_IO.Create (UnZ_IO.out_bin_file, Ada.Streams.Stream_IO.Out_File, output_file_name,
1970 Form => To_String (Zip_Streams.Form_For_IO_Open_and_Create));
1971 when write_to_text_file =>
1972 Ada.Text_IO.Create (UnZ_IO.out_txt_file, Ada.Text_IO.Out_File, output_file_name,
1973 Form => To_String (Zip_Streams.Form_For_IO_Open_and_Create));
1974 when write_to_memory =>
1975 output_memory_access := new
1976 Ada.Streams.Stream_Element_Array (
1977 1 .. Ada.Streams.Stream_Element_Offset (hint.dd.uncompressed_size)
1978 );
1979 UnZ_Glob.uncompressed_index := output_memory_access'First;
1980 when write_to_stream | just_test =>
1981 null;
1982 end case;
1983
1984 UnZ_Glob.compsize := hint.dd.compressed_size;
1985 UnZ_Glob.uncompsize := hint.dd.uncompressed_size;
1986 UnZ_IO.Init_Buffers;
1987 if is_encrypted then
1988 Set_Mode (local_crypto_pack, encrypted);
1989 work_index := Zip_Streams.Index (zip_file);
1990 password_passes : for pass in 1 .. tolerance_wrong_password loop
1991 begin
1992 Init_Decryption (To_String (password), hint.dd.crc_32);
1993 exit password_passes; -- the current password fits, then go on!
1994 exception
1995 when Wrong_password =>
1996 if pass = tolerance_wrong_password then
1997 raise;
1998 elsif get_new_password /= null then
1999 get_new_password (password); -- ask for a new one
2000 end if;
2001 end;
2002 -- Go back to data beginning:
2003 begin
2004 Zip_Streams.Set_Index (zip_file, work_index);
2005 exception
2006 when others =>
2007 raise UnZip.Read_Error with "Failure after password interaction";
2008 end;
2009 UnZ_IO.Init_Buffers;
2010 end loop password_passes;
2011 else
2012 Set_Mode (local_crypto_pack, clear);
2013 end if;
2014
2015 -- UnZip correct type
2016 begin
2017 case format is
2018 when store => Copy_stored;
2019 when shrink => Unshrink;
2020 when Reduce_Format => Unreduce (1 + Reduce_Format'Pos (format) - Reduce_Format'Pos (reduce_1));
2021 when implode =>
2022 UnZ_Meth.Explode (explode_literal_tree, explode_slide_8KB_LZMA_EOS);
2023 when deflate | deflate_e =>
2024 UnZ_Meth.deflate_e_mode := format = deflate_e;
2025 UnZ_Meth.Inflate;
2026 when Zip.bzip2_meth => UnZ_Meth.Bunzip2;
2027 when Zip.lzma_meth => UnZ_Meth.LZMA_Decode;
2028 when others =>
2029 raise Unsupported_method with
2030 "Format/method " & Image (format) &
2031 " not supported for decompression";
2032 end case;
2033 exception
2034 when others =>
2035 UnZ_IO.Delete_output;
2036 raise;
2037 end;
2038 UnZ_Glob.crc32val := Zip.CRC_Crypto.Final (UnZ_Glob.crc32val);
2039 -- Decompression done !
2040
2041 if data_descriptor_after_data then -- Sizes and CRC at the end
2042 declare
2043 memo_uncomp_size : constant Zip.Zip_64_Data_Size_Type := hint.dd.uncompressed_size;
2044 begin
2045 Process_descriptor (hint.dd); -- CRC is for checking; sizes are for informing user
2046 if memo_uncomp_size < Zip_64_Data_Size_Type (Zip_32_Data_Size_Type'Last) and then --
2047 memo_uncomp_size /= hint.dd.uncompressed_size
2048 then
2049 UnZ_IO.Delete_output;
2050 raise Uncompressed_Size_Error
2051 with "Uncompressed size mismatch: in catalogue:" & memo_uncomp_size'Image &
2052 "; in post-data data descriptor:" & hint.dd.uncompressed_size'Image;
2053 end if;
2054 end;
2055 end if;
2056
2057 if hint.dd.crc_32 /= UnZ_Glob.crc32val then
2058 UnZ_IO.Delete_output;
2059 raise CRC_Error with
2060 "CRC stored in archive: " & Hexadecimal (hint.dd.crc_32) &
2061 "; CRC computed now: " & Hexadecimal (UnZ_Glob.crc32val);
2062 end if;
2063
2064 case write_mode is
2065 when write_to_binary_file =>
2066 Ada.Streams.Stream_IO.Close (UnZ_IO.out_bin_file);
2067 when write_to_text_file =>
2068 Ada.Text_IO.Close (UnZ_IO.out_txt_file);
2069 when write_to_memory | write_to_stream | just_test =>
2070 null; -- Nothing to close!
2071 end case;
2072 if some_trace then
2073 Ada.Text_IO.Close (LZ77_dump);
2074 end if;
2075
2076 exception
2077 when others => -- close the file in case of an error, if not yet closed
2078 case write_mode is -- or deleted
2079 when write_to_binary_file =>
2080 if Ada.Streams.Stream_IO.Is_Open (UnZ_IO.out_bin_file) then
2081 Ada.Streams.Stream_IO.Close (UnZ_IO.out_bin_file);
2082 end if;
2083 when write_to_text_file =>
2084 if Ada.Text_IO.Is_Open (UnZ_IO.out_txt_file) then
2085 Ada.Text_IO.Close (UnZ_IO.out_txt_file);
2086 end if;
2087 when write_to_memory | write_to_stream | just_test =>
2088 null; -- Nothing to close!
2089 end case;
2090 raise;
2091 end Decompress_Data;
2092
2093 end UnZip.Decompress;
Web view of Ada source code generated by GNATHTML, project: ALI_Parse version 1.0.
Zip-Ada: Ada library for zip archive files (.zip).
Ada programming.
Some news about Zip-Ada and other Ada projects
on Gautier's blog.