Source file : zip.adb
1 -- Legal licensing note:
2
3 -- Copyright (c) 1999 .. 2025 Gautier de Montmollin
4 -- SWITZERLAND
5
6 -- Permission is hereby granted, free of charge, to any person obtaining a copy
7 -- of this software and associated documentation files (the "Software"), to deal
8 -- in the Software without restriction, including without limitation the rights
9 -- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
10 -- copies of the Software, and to permit persons to whom the Software is
11 -- furnished to do so, subject to the following conditions:
12
13 -- The above copyright notice and this permission notice shall be included in
14 -- all copies or substantial portions of the Software.
15
16 -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17 -- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18 -- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19 -- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20 -- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
21 -- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
22 -- THE SOFTWARE.
23
24 -- NB: this is the MIT License, as found 12-Sep-2007 on the site
25 -- http://www.opensource.org/licenses/mit-license.php
26
27 with Zip.Headers;
28
29 with Ada.Characters.Handling,
30 Ada.Exceptions,
31 Ada.Unchecked_Deallocation,
32 Ada.IO_Exceptions,
33 Ada.Strings.Fixed,
34 Ada.Strings.Unbounded;
35
36 package body Zip is
37
38 use Interfaces;
39
40 procedure Dispose is new Ada.Unchecked_Deallocation (Dir_node, p_Dir_node);
41 procedure Dispose is new Ada.Unchecked_Deallocation (String, p_String);
42
43 package Binary_tree_rebalancing is
44 procedure Rebalance (root : in out p_Dir_node);
45 end Binary_tree_rebalancing;
46
47 package body Binary_tree_rebalancing is
48
49 --------------------------------------------------------------------
50 -- Tree Rebalancing in Optimal Time and Space --
51 -- QUENTIN F. STOUT and BETTE L. WARREN --
52 -- Communications of the ACM September 1986 Volume 29 Number 9 --
53 --------------------------------------------------------------------
54 -- http://www.eecs.umich.edu/~qstout/pap/CACM86.pdf
55 --
56 -- Translated by (New) P2Ada v. 15-Nov-2006
57
58 procedure Tree_to_vine (root : p_Dir_node; size : out Integer)
59 -- transform the tree with pseudo-root
60 -- "root^" into a vine with pseudo-root
61 -- node "root^", and store the number of
62 -- nodes in "size"
63 is
64 vine_tail, remainder, temp : p_Dir_node;
65 begin
66 vine_tail := root;
67 remainder := vine_tail.right;
68 size := 0;
69 while remainder /= null loop
70 if remainder.left = null then
71 -- move vine-tail down one:
72 vine_tail := remainder;
73 remainder := remainder.right;
74 size := size + 1;
75 else
76 -- rotate:
77 temp := remainder.left;
78 remainder.left := temp.right;
79 temp.right := remainder;
80 remainder := temp;
81 vine_tail.right := temp;
82 end if;
83 end loop;
84 end Tree_to_vine;
85
86 procedure Vine_to_tree (root : p_Dir_node; size_given : Integer) is
87 -- convert the vine with "size" nodes and pseudo-root
88 -- node "root^" into a balanced tree
89 leaf_count : Integer;
90 size : Integer := size_given;
91
92 procedure Compression (root_compress : p_Dir_node; count : Integer) is
93 -- Compress "count" spine nodes in the tree with pseudo-root "root_compress^"
94 scanner, child : p_Dir_node;
95 begin
96 scanner := root_compress;
97 for counter in reverse 1 .. count loop
98 child := scanner.right;
99 scanner.right := child.right;
100 scanner := scanner.right;
101 child.right := scanner.left;
102 scanner.left := child;
103 end loop;
104 end Compression;
105
106 -- Returns n - 2 ** Integer( Float'Floor( log( Float(n) ) / log(2.0) ) )
107 -- without Float-Point calculation and rounding errors with too short floats
108 function Remove_leading_binary_1 (n : Integer) return Integer is
109 x : Integer := 2**16; -- supposed maximum
110 begin
111 if n < 1 then
112 return n;
113 end if;
114 while n mod x = n loop
115 x := x / 2;
116 end loop;
117 return n mod x;
118 end Remove_leading_binary_1;
119
120 begin -- Vine_to_tree
121 leaf_count := Remove_leading_binary_1 (size + 1);
122 Compression (root, leaf_count); -- create deepest leaves
123 -- use Perfect_leaves instead for a perfectly balanced tree
124 size := size - leaf_count;
125 while size > 1 loop
126 Compression (root, size / 2);
127 size := size / 2;
128 end loop;
129 end Vine_to_tree;
130
131 procedure Rebalance (root : in out p_Dir_node) is
132 -- Rebalance the binary search tree with root "root.all",
133 -- with the result also rooted at "root.all".
134 -- Uses the Tree_to_vine and Vine_to_tree procedures.
135 pseudo_root : p_Dir_node;
136 size : Integer;
137 begin
138 pseudo_root := new Dir_node (name_len => 0);
139 pseudo_root.right := root;
140 Tree_to_vine (pseudo_root, size);
141 Vine_to_tree (pseudo_root, size);
142 root := pseudo_root.right;
143 Dispose (pseudo_root);
144 end Rebalance;
145
146 end Binary_tree_rebalancing;
147
148 -- 19-Jun-2001: Enhanced file name identification
149 -- a) when case insensitive -> all UPPER (current)
150 -- b) '\' and '/' identified -> all '/' (new)
151
152 function Normalize (s : String; case_sensitive : Boolean) return String is
153 sn : String (s'Range);
154 begin
155 if case_sensitive then
156 sn := s;
157 else
158 sn := Ada.Characters.Handling.To_Upper (s);
159 end if;
160 for i in sn'Range loop
161 if sn (i) = '\' then
162 sn (i) := '/';
163 end if;
164 end loop;
165 return sn;
166 end Normalize;
167
168 boolean_to_encoding : constant array (Boolean) of Zip_Name_Encoding :=
169 (False => IBM_437, True => UTF_8);
170
171 -------------------------------------------------------------
172 -- Load Zip_info from a stream containing the .zip archive --
173 -------------------------------------------------------------
174
175 procedure Load
176 (info : out Zip_Info;
177 from : in out Zip_Streams.Root_Zipstream_Type'Class;
178 case_sensitive : in Boolean := False;
179 duplicate_names : in Duplicate_name_policy := error_on_duplicate)
180 is
181 procedure Insert
182 (dico_name : String; -- UPPER if case-insensitive search
183 file_name : String;
184 file_index : Zip_Streams.ZS_Index_Type;
185 comp_size,
186 uncomp_size : Zip_64_Data_Size_Type;
187 crc_32 : Unsigned_32;
188 date_time : Time;
189 method : PKZip_method;
190 name_encoding : Zip_Name_Encoding;
191 read_only : Boolean;
192 encrypted_2_x : Boolean;
193 root_node : in out p_Dir_node)
194 is
195 procedure Insert_into_tree (node : in out p_Dir_node) is
196 begin
197 if node = null then
198 node := new Dir_node'
199 ((name_len => file_name'Length,
200 left => null,
201 right => null,
202 dico_name => dico_name,
203 file_name => file_name,
204 file_index => file_index,
205 comp_size => comp_size,
206 uncomp_size => uncomp_size,
207 crc_32 => crc_32,
208 date_time => date_time,
209 method => method,
210 name_encoding => name_encoding,
211 read_only => read_only,
212 encrypted_2_x => encrypted_2_x,
213 user_code => 0
214 )
215 );
216 elsif dico_name > node.dico_name then
217 Insert_into_tree (node.right);
218 elsif dico_name < node.dico_name then
219 Insert_into_tree (node.left);
220 else
221 -- Here we have a case where the entry name already exists in the dictionary.
222 case duplicate_names is
223 when error_on_duplicate =>
224 raise Duplicate_name with
225 "Same full entry name (in dictionary: " & dico_name &
226 ") appears twice in archive directory; " &
227 "procedure Load was called with strict name policy.";
228 when admit_duplicates =>
229 if file_index > node.file_index then
230 Insert_into_tree (node.right);
231 elsif file_index < node.file_index then
232 Insert_into_tree (node.left);
233 else
234 raise Duplicate_name with
235 "Archive directory corrupt: same full entry name (in dictionary: " &
236 dico_name & "), with same data position, appear twice.";
237 end if;
238 end case;
239 end if;
240 end Insert_into_tree;
241 --
242 begin
243 Insert_into_tree (root_node);
244 end Insert;
245
246 the_end : Zip.Headers.End_of_Central_Dir;
247 header : Zip.Headers.Central_File_Header;
248 p : p_Dir_node := null;
249 main_comment : p_String;
250 begin -- Load Zip_info
251 if info.loaded then
252 Delete (info);
253 end if;
254 Zip.Headers.Load (from, the_end);
255 -- We take the opportunity to read the main comment, which is right
256 -- after the end-of-central-directory block.
257 main_comment := new String (1 .. Integer (the_end.main_comment_length));
258 String'Read (from'Access, main_comment.all);
259 -- Process central directory:
260 Zip_Streams.Set_Index (
261 from,
262 Zip_Streams.ZS_Index_Type (1 + the_end.central_dir_offset) + the_end.offset_shifting
263 );
264
265 for i in 1 .. the_end.total_entries loop
266 Zip.Headers.Read_and_Check (from, header);
267 declare
268 this_name : String (1 .. Natural (header.short_info.filename_length));
269 mem : Zip_Streams.ZS_Index_Type;
270 head_extra : Headers.Local_File_Header_Extension;
271 begin
272 String'Read (from'Access, this_name);
273 mem := from.Index;
274 if header.short_info.extra_field_length >= 4 then
275 Headers.Read_and_Check (from, head_extra);
276 Headers.Interpret
277 (head_extra,
278 header.short_info.dd.uncompressed_size,
279 header.short_info.dd.compressed_size,
280 header.local_header_offset);
281 end if;
282 -- Skip extra field and entry comment.
283 from.Set_Index
284 (mem +
285 Zip_Streams.ZS_Size_Type
286 (header.short_info.extra_field_length +
287 header.comment_length));
288 -- Now the whole i_th central directory entry is behind
289 Insert (dico_name => Normalize (this_name, case_sensitive),
290 file_name => Normalize (this_name, True),
291 file_index => Zip_Streams.ZS_Index_Type (1 + header.local_header_offset) +
292 the_end.offset_shifting,
293 comp_size => header.short_info.dd.compressed_size,
294 uncomp_size => header.short_info.dd.uncompressed_size,
295 crc_32 => header.short_info.dd.crc_32,
296 date_time => header.short_info.file_timedate,
297 method => Method_from_Code (header.short_info.zip_type),
298 name_encoding =>
299 boolean_to_encoding (
300 (header.short_info.bit_flag and
301 Zip.Headers.Language_Encoding_Flag_Bit) /= 0),
302 read_only => header.made_by_version / 256 = 0 and -- DOS-like
303 (header.external_attributes and 1) = 1,
304 encrypted_2_x => (header.short_info.bit_flag and Zip.Headers.Encryption_Flag_Bit) /= 0,
305 root_node => p);
306 -- Since the files are usually well ordered, the tree as inserted
307 -- is very unbalanced; we need to rebalance it from time to time
308 -- during loading, otherwise the insertion slows down dramatically
309 -- for zip files with plenty of files - converges to
310 -- O(total_entries ** 2)...
311 if i mod 256 = 0 then
312 Binary_tree_rebalancing.Rebalance (p);
313 end if;
314 end;
315 end loop;
316 Binary_tree_rebalancing.Rebalance (p);
317 info.loaded := True;
318 info.case_sensitive := case_sensitive;
319 info.zip_file_name := new String'("This is a stream, no direct file!");
320 info.zip_input_stream := from'Unchecked_Access;
321 info.dir_binary_tree := p;
322 info.total_entries := Integer (the_end.total_entries);
323 info.zip_file_comment := main_comment;
324 info.zip_archive_format := Zip_32;
325 exception
326 when E : Zip.Headers.bad_end =>
327 raise Zip.Archive_corrupted
328 with "Bad (or no) end-of-central-directory " & Ada.Exceptions.Exception_Message (E);
329 when Zip.Headers.bad_central_header =>
330 raise Zip.Archive_corrupted with "Bad central directory entry header";
331 end Load;
332
333 -----------------------------------------------------------
334 -- Load Zip_info from a file containing the .zip archive --
335 -----------------------------------------------------------
336
337 procedure Load
338 (info : out Zip_Info;
339 from : in String; -- Zip file name
340 case_sensitive : in Boolean := False;
341 duplicate_names : in Duplicate_name_policy := error_on_duplicate)
342 is
343 my_stream : aliased Zip_Streams.File_Zipstream;
344 begin
345 my_stream.Set_Name (from);
346 begin
347 my_stream.Open (Zip_Streams.In_File);
348 exception
349 when others =>
350 raise Archive_open_error with "Archive: [" & from & ']';
351 end;
352 -- Call the stream version of Load(...)
353 Load (
354 info,
355 my_stream,
356 case_sensitive,
357 duplicate_names
358 );
359 my_stream.Close;
360 Dispose (info.zip_file_name);
361 info.zip_file_name := new String'(from);
362 info.zip_input_stream := null; -- forget about the stream!
363 exception
364 when others =>
365 if my_stream.Is_Open then
366 my_stream.Close;
367 end if;
368 raise;
369 end Load;
370
371 function Is_loaded (info : in Zip_Info) return Boolean is
372 begin
373 return info.loaded;
374 end Is_loaded;
375
376 function Zip_Name (info : in Zip_Info) return String is
377 begin
378 if not info.loaded then
379 raise Forgot_to_load_zip_info;
380 end if;
381 return info.zip_file_name.all;
382 end Zip_Name;
383
384 function Zip_Comment (info : in Zip_Info) return String is
385 begin
386 if not info.loaded then
387 raise Forgot_to_load_zip_info;
388 end if;
389 return info.zip_file_comment.all;
390 end Zip_Comment;
391
392 function Zip_Stream (info : in Zip_Info) return Zip_Streams.Zipstream_Class_Access
393 is
394 begin
395 if not info.loaded then
396 raise Forgot_to_load_zip_info;
397 end if;
398 return info.zip_input_stream;
399 end Zip_Stream;
400
401 function Entries (info : in Zip_Info) return Natural is
402 begin
403 return info.total_entries;
404 end Entries;
405
406 ------------
407 -- Delete --
408 ------------
409
410 procedure Delete (info : in out Zip_Info) is
411
412 procedure Delete (p : in out p_Dir_node) is
413 begin
414 if p /= null then
415 Delete (p.left);
416 Delete (p.right);
417 Dispose (p);
418 p := null;
419 end if;
420 end Delete;
421
422 begin
423 Delete (info.dir_binary_tree);
424 Dispose (info.zip_file_name);
425 Dispose (info.zip_file_comment);
426 info.loaded := False; -- <-- added 14-Jan-2002
427 end Delete;
428
429 -- Traverse a whole Zip_info directory in sorted order, giving the
430 -- name for each entry to an user-defined "Action" procedure.
431
432 generic
433 with procedure Action_private (dn : in out Dir_node);
434 -- Dir_node is private: only known to us, contents subject to change
435 procedure Traverse_private (z : Zip_Info);
436
437 procedure Traverse_private (z : Zip_Info) is
438
439 procedure Traverse_tree (p : p_Dir_node) is
440 begin
441 if p /= null then
442 Traverse_tree (p.left);
443 Action_private (p.all);
444 Traverse_tree (p.right);
445 end if;
446 end Traverse_tree;
447
448 begin
449 Traverse_tree (z.dir_binary_tree);
450 end Traverse_private;
451
452 -----------------------
453 -- Public versions --
454 -----------------------
455
456 procedure Traverse (z : Zip_Info) is
457 procedure My_Action_private (dn : in out Dir_node) is
458 pragma Inline (My_Action_private);
459 begin
460 Action (dn.file_name);
461 end My_Action_private;
462 procedure My_Traverse_private is new Traverse_private (My_Action_private);
463 begin
464 My_Traverse_private (z);
465 end Traverse;
466
467 procedure Traverse_Unicode (z : Zip_Info) is
468 procedure My_Action_private (dn : in out Dir_node) is
469 pragma Inline (My_Action_private);
470 begin
471 Action (dn.file_name, dn.name_encoding);
472 end My_Action_private;
473 procedure My_Traverse_private is new Traverse_private (My_Action_private);
474 begin
475 My_Traverse_private (z);
476 end Traverse_Unicode;
477
478 procedure Traverse_verbose (z : Zip_Info) is
479 procedure My_Action_private (dn : in out Dir_node) is
480 pragma Inline (My_Action_private);
481 begin
482 Action (
483 dn.file_name,
484 dn.file_index,
485 dn.comp_size,
486 dn.uncomp_size,
487 dn.crc_32,
488 dn.date_time,
489 dn.method,
490 dn.name_encoding,
491 dn.read_only,
492 dn.encrypted_2_x,
493 dn.user_code
494 );
495 end My_Action_private;
496 procedure My_Traverse_private is new Traverse_private (My_Action_private);
497 begin
498 My_Traverse_private (z);
499 end Traverse_verbose;
500
501 procedure Tree_Stat
502 (z : in Zip_Info;
503 total : out Natural;
504 max_depth : out Natural;
505 avg_depth : out Float)
506 is
507 sum_depth : Natural := 0;
508
509 procedure Traverse_tree (p : p_Dir_node; depth : Natural) is
510 begin
511 if p /= null then
512 total := total + 1;
513 if depth > max_depth then
514 max_depth := depth;
515 end if;
516 sum_depth := sum_depth + depth;
517 Traverse_tree (p.left, depth + 1);
518 Traverse_tree (p.right, depth + 1);
519 end if;
520 end Traverse_tree;
521
522 begin
523 total := 0;
524 max_depth := 0;
525 Traverse_tree (z.dir_binary_tree, 0);
526 if total = 0 then
527 avg_depth := 0.0;
528 else
529 avg_depth := Float (sum_depth) / Float (total);
530 end if;
531 end Tree_Stat;
532
533 -- 13-May-2001: Find_first_offset
534
535 -- For an all-files unzipping of an appended (e.g. self-extracting) archive
536 -- (not beginning with ZIP contents), we cannot start with
537 -- index 1 in file.
538 -- But the offset of first entry in ZIP directory is not valid either,
539 -- as this excerpt of appnote.txt states:
540
541 -- " 4) The entries in the central directory may not necessarily
542 -- be in the same order that files appear in the zipfile. "
543
544 procedure Find_first_Offset (
545 file : in out Zip_Streams.Root_Zipstream_Type'Class;
546 file_index : out Zip_Streams.ZS_Index_Type
547 )
548 is
549 the_end : Zip.Headers.End_of_Central_Dir;
550 header : Zip.Headers.Central_File_Header;
551 min_offset : Zip_64_Data_Size_Type;
552 mem : Zip_Streams.ZS_Index_Type;
553 head_extra : Headers.Local_File_Header_Extension;
554 begin
555 Zip.Headers.Load (file, the_end);
556 file.Set_Index
557 (Zip_Streams.ZS_Index_Type (1 + the_end.central_dir_offset) + the_end.offset_shifting);
558
559 min_offset := the_end.central_dir_offset; -- will be lowered if the archive is not empty.
560
561 if the_end.total_entries = 0 then
562 raise Archive_is_empty;
563 end if;
564
565 for i in 1 .. the_end.total_entries loop
566 Headers.Read_and_Check (file, header);
567 file.Set_Index (file.Index + Zip_Streams.ZS_Size_Type (header.short_info.filename_length));
568 mem := file.Index;
569 if header.short_info.extra_field_length >= 4 then
570 Headers.Read_and_Check (file, head_extra);
571 Headers.Interpret
572 (head_extra,
573 header.short_info.dd.uncompressed_size,
574 header.short_info.dd.compressed_size,
575 header.local_header_offset);
576 end if;
577 file.Set_Index
578 (mem +
579 Zip_Streams.ZS_Size_Type
580 (header.short_info.extra_field_length +
581 header.comment_length));
582 -- Now the whole i_th central directory entry is behind
583
584 if header.local_header_offset < min_offset then
585 min_offset := header.local_header_offset;
586 end if;
587 end loop;
588
589 file_index := Zip_Streams.ZS_Index_Type (1 + min_offset) + the_end.offset_shifting;
590
591 exception
592 when E : Zip.Headers.bad_end =>
593 raise Zip.Archive_corrupted
594 with "Bad (or no) end-of-central-directory " & Ada.Exceptions.Exception_Message (E);
595 when Ada.IO_Exceptions.End_Error =>
596 raise Zip.Archive_corrupted
597 with "Bad (or no) end-of-central-directory (end of stream reached)";
598 when Zip.Headers.bad_central_header =>
599 raise Zip.Archive_corrupted with "Bad central directory entry header";
600 end Find_first_Offset;
601
602 -- Internal: find offset of a zipped file by reading sequentially the
603 -- central directory :-(
604
605 procedure Find_Offset (
606 file : in out Zip_Streams.Root_Zipstream_Type'Class;
607 name : in String;
608 case_sensitive : in Boolean;
609 file_index : out Zip_Streams.ZS_Index_Type;
610 comp_size : out Zip_64_Data_Size_Type;
611 uncomp_size : out Zip_64_Data_Size_Type;
612 crc_32 : out Interfaces.Unsigned_32
613 )
614 is
615 the_end : Zip.Headers.End_of_Central_Dir;
616 header : Zip.Headers.Central_File_Header;
617 mem : Zip_Streams.ZS_Index_Type;
618 head_extra : Headers.Local_File_Header_Extension;
619 begin
620 Zip.Headers.Load (file, the_end);
621 file.Set_Index
622 (Zip_Streams.ZS_Index_Type (1 + the_end.central_dir_offset) + the_end.offset_shifting);
623 for i in 1 .. the_end.total_entries loop
624 Zip.Headers.Read_and_Check (file, header);
625 declare
626 this_name : String (1 .. Natural (header.short_info.filename_length));
627 begin
628 String'Read (file'Access, this_name);
629 mem := file.Index;
630 if header.short_info.extra_field_length >= 4 then
631 Headers.Read_and_Check (file, head_extra);
632 Headers.Interpret
633 (head_extra,
634 header.short_info.dd.uncompressed_size,
635 header.short_info.dd.compressed_size,
636 header.local_header_offset);
637 end if;
638 file.Set_Index
639 (mem +
640 Zip_Streams.ZS_Size_Type
641 (header.short_info.extra_field_length +
642 header.comment_length));
643 -- Now the whole i_th central directory entry is behind
644 if Normalize (this_name, case_sensitive) =
645 Normalize (name, case_sensitive)
646 then
647 -- Name found in central directory !
648 file_index := Zip_Streams.ZS_Index_Type (1 + header.local_header_offset) + the_end.offset_shifting;
649 comp_size := Zip_64_Data_Size_Type (header.short_info.dd.compressed_size);
650 uncomp_size := Zip_64_Data_Size_Type (header.short_info.dd.uncompressed_size);
651 crc_32 := header.short_info.dd.crc_32;
652 return;
653 end if;
654 end;
655 end loop;
656 raise Entry_name_not_found with "Entry: [" & name & ']';
657 exception
658 when Zip.Headers.bad_end =>
659 raise Zip.Archive_corrupted with "Bad (or no) end-of-central-directory";
660 when Zip.Headers.bad_central_header =>
661 raise Zip.Archive_corrupted with "Bad central directory entry header";
662 end Find_Offset;
663
664 -- Internal: find offset of a zipped file using the zip_info tree 8-)
665
666 procedure Find_Offset
667 (info : in Zip_Info;
668 name : in String;
669 name_encoding : out Zip_Name_Encoding;
670 file_index : out Zip_Streams.ZS_Index_Type;
671 comp_size : out Zip_64_Data_Size_Type;
672 uncomp_size : out Zip_64_Data_Size_Type;
673 crc_32 : out Interfaces.Unsigned_32)
674 is
675 aux : p_Dir_node := info.dir_binary_tree;
676 up_name : constant String := Normalize (name, info.case_sensitive);
677 begin
678 if not info.loaded then
679 raise Forgot_to_load_zip_info;
680 end if;
681 while aux /= null loop
682 if up_name > aux.dico_name then
683 aux := aux.right;
684 elsif up_name < aux.dico_name then
685 aux := aux.left;
686 else -- entry found !
687 name_encoding := aux.name_encoding;
688 file_index := aux.file_index;
689 comp_size := aux.comp_size;
690 uncomp_size := aux.uncomp_size;
691 crc_32 := aux.crc_32;
692 return;
693 end if;
694 end loop;
695 raise Entry_name_not_found with "Archive: [" & info.zip_file_name.all & "], entry: [" & name & ']';
696 end Find_Offset;
697
698 procedure Find_Offset_without_Directory
699 (info : in Zip_Info;
700 name : in String;
701 name_encoding : out Zip_Name_Encoding;
702 file_index : out Zip_Streams.ZS_Index_Type;
703 comp_size : out Zip_64_Data_Size_Type;
704 uncomp_size : out Zip_64_Data_Size_Type;
705 crc_32 : out Interfaces.Unsigned_32)
706 is
707 function Trash_dir (n : String) return String is
708 idx : Integer := n'First - 1;
709 begin
710 for i in n'Range loop
711 if n (i) in '/' | '\' then
712 idx := i;
713 end if;
714 end loop;
715 -- idx points on the index just before the interesting part
716 return Normalize (n (idx + 1 .. n'Last), info.case_sensitive);
717 end Trash_dir;
718
719 simple_name : constant String := Trash_dir (name);
720
721 Found : exception;
722
723 procedure Check_entry (
724 entry_name : String; -- 'name' is compressed entry's name
725 entry_index : Zip_Streams.ZS_Index_Type;
726 entry_comp_size : Zip_64_Data_Size_Type;
727 entry_uncomp_size : Zip_64_Data_Size_Type;
728 entry_crc_32 : Interfaces.Unsigned_32;
729 date_time : Time;
730 method : PKZip_method;
731 entry_name_encoding : Zip_Name_Encoding;
732 read_only : Boolean;
733 encrypted_2_x : Boolean; -- PKZip 2.x encryption
734 entry_user_code : in out Integer
735 )
736 is
737 pragma Unreferenced (date_time, method, read_only, encrypted_2_x, entry_user_code);
738 begin
739 if Trash_dir (entry_name) = simple_name then
740 name_encoding := entry_name_encoding;
741 file_index := entry_index;
742 comp_size := entry_comp_size;
743 uncomp_size := entry_uncomp_size;
744 crc_32 := entry_crc_32;
745 raise Found;
746 end if;
747 end Check_entry;
748 --
749 procedure Search is new Traverse_verbose (Check_entry);
750 --
751 begin
752 begin
753 Search (info);
754 exception
755 when Found =>
756 return;
757 end;
758 raise Entry_name_not_found with "Archive: [" & info.zip_file_name.all & "], entry: [" & name & ']';
759 end Find_Offset_without_Directory;
760
761 function Exists (info : Zip_Info; name : String) return Boolean
762 is
763 aux : p_Dir_node := info.dir_binary_tree;
764 up_name : constant String := Normalize (name, info.case_sensitive);
765 begin
766 if not info.loaded then
767 raise Forgot_to_load_zip_info;
768 end if;
769 while aux /= null loop
770 if up_name > aux.dico_name then
771 aux := aux.right;
772 elsif up_name < aux.dico_name then
773 aux := aux.left;
774 else -- entry found !
775 return True;
776 end if;
777 end loop;
778 return False;
779 end Exists;
780
781 procedure Set_User_Code (info : Zip_Info; name : String; code : Integer) is
782 aux : p_Dir_node := info.dir_binary_tree;
783 up_name : constant String := Normalize (name, info.case_sensitive);
784 begin
785 if not info.loaded then
786 raise Forgot_to_load_zip_info;
787 end if;
788 while aux /= null loop
789 if up_name > aux.dico_name then
790 aux := aux.right;
791 elsif up_name < aux.dico_name then
792 aux := aux.left;
793 else -- entry found !
794 aux.user_code := code;
795 return;
796 end if;
797 end loop;
798 raise Entry_name_not_found with "Archive: [" & info.zip_file_name.all & "], entry: [" & name & ']';
799 end Set_User_Code;
800
801 function User_Code (info : Zip_Info; name : String) return Integer
802 is
803 aux : p_Dir_node := info.dir_binary_tree;
804 up_name : constant String := Normalize (name, info.case_sensitive);
805 begin
806 if not info.loaded then
807 raise Forgot_to_load_zip_info;
808 end if;
809 while aux /= null loop
810 if up_name > aux.dico_name then
811 aux := aux.right;
812 elsif up_name < aux.dico_name then
813 aux := aux.left;
814 else -- entry found !
815 return aux.user_code;
816 end if;
817 end loop;
818 raise Entry_name_not_found with "Archive: [" & info.zip_file_name.all & "], entry: [" & name & ']';
819 return 0; -- Fake, since exception has been raised just before. Removes an OA warning.
820 end User_Code;
821
822 procedure Get_Sizes
823 (info : in Zip_Info;
824 name : in String;
825 comp_size : out Zip_64_Data_Size_Type;
826 uncomp_size : out Zip_64_Data_Size_Type)
827 is
828 dummy_file_index : Zip_Streams.ZS_Index_Type;
829 dummy_name_encoding : Zip_Name_Encoding;
830 dummy_crc_32 : Interfaces.Unsigned_32;
831 begin
832 Find_Offset
833 (info, name, dummy_name_encoding, dummy_file_index,
834 comp_size, uncomp_size, dummy_crc_32);
835 end Get_Sizes;
836
837 -- Workaround for the severe xxx'Read xxx'Write performance
838 -- problems in the GNAT and ObjectAda compilers (as in 2009)
839 -- This is possible if and only if Byte = Stream_Element and
840 -- arrays types are both packed and aligned the same way.
841 --
842 subtype Size_test_a is Byte_Buffer (1 .. 19);
843 subtype Size_test_b is Ada.Streams.Stream_Element_Array (1 .. 19);
844 workaround_possible : constant Boolean :=
845 Size_test_a'Size = Size_test_b'Size and
846 Size_test_a'Alignment = Size_test_b'Alignment;
847
848 -- Block_Read - general-purpose procedure (nothing really specific
849 -- to Zip / UnZip): reads either the whole buffer from a file, or
850 -- if the end of the file lays inbetween, a part of the buffer.
851
852 procedure Block_Read
853 (file : in Ada.Streams.Stream_IO.File_Type;
854 buffer : out Byte_Buffer;
855 actually_read : out Natural)
856 is
857 use Ada.Streams, Ada.Streams.Stream_IO;
858 SE_Buffer : Stream_Element_Array (1 .. buffer'Length);
859 for SE_Buffer'Address use buffer'Address;
860 pragma Import (Ada, SE_Buffer);
861 Last_Read : Stream_Element_Offset;
862 begin
863 if workaround_possible then
864 Read (Stream (file).all, SE_Buffer, Last_Read);
865 actually_read := Natural (Last_Read);
866 else
867 if End_Of_File (file) then
868 actually_read := 0;
869 else
870 actually_read :=
871 Integer'Min (buffer'Length, Integer (Size (file) - Index (file) + 1));
872 Byte_Buffer'Read (
873 Stream (file),
874 buffer (buffer'First .. buffer'First + actually_read - 1)
875 );
876 end if;
877 end if;
878 end Block_Read;
879
880 procedure Block_Read
881 (stream : in out Zip_Streams.Root_Zipstream_Type'Class;
882 buffer : out Byte_Buffer;
883 actually_read : out Natural)
884 is
885 use Ada.Streams;
886 SE_Buffer : Stream_Element_Array (1 .. buffer'Length);
887 for SE_Buffer'Address use buffer'Address;
888 pragma Import (Ada, SE_Buffer);
889 Last_Read : Stream_Element_Offset;
890 begin
891 if workaround_possible then
892 stream.Read (SE_Buffer, Last_Read);
893 actually_read := Natural (Last_Read);
894 else
895 if stream.End_Of_Stream then
896 actually_read := 0;
897 else
898 actually_read :=
899 Integer'Min (buffer'Length, Integer (stream.Size - stream.Index + 1));
900 Byte_Buffer'Read (
901 stream'Access,
902 buffer (buffer'First .. buffer'First + actually_read - 1)
903 );
904 end if;
905 end if;
906 end Block_Read;
907
908 procedure Block_Read
909 (stream : in out Zip_Streams.Root_Zipstream_Type'Class;
910 buffer : out Byte_Buffer)
911 is
912 actually_read : Natural;
913 begin
914 Block_Read (stream, buffer, actually_read);
915 if actually_read < buffer'Length then
916 raise Ada.IO_Exceptions.End_Error;
917 end if;
918 end Block_Read;
919
920 procedure Block_Write
921 (stream : in out Ada.Streams.Root_Stream_Type'Class;
922 buffer : in Byte_Buffer)
923 is
924 use Ada.Streams;
925 SE_Buffer : Stream_Element_Array (1 .. buffer'Length);
926 for SE_Buffer'Address use buffer'Address;
927 pragma Import (Ada, SE_Buffer);
928 begin
929 if workaround_possible then
930 Ada.Streams.Write (stream, SE_Buffer);
931 else
932 Byte_Buffer'Write (stream'Access, buffer);
933 -- ^This is 30x to 70x slower on GNAT 2009 !
934 end if;
935 end Block_Write;
936
937 function Image (m : PKZip_method) return String is
938 begin
939 case m is
940 when store => return "Store";
941 when shrink => return "Shrink";
942 when reduce_1 => return "Reduce 1";
943 when reduce_2 => return "Reduce 2";
944 when reduce_3 => return "Reduce 3";
945 when reduce_4 => return "Reduce 4";
946 when implode => return "Implode";
947 when tokenize => return "Tokenize";
948 when deflate => return "Deflate";
949 when deflate_e => return "Deflate64";
950 when bzip2_meth => return "BZip2";
951 when lzma_meth => return "LZMA";
952 when zstandard => return "Zstandard";
953 when mp3_recomp => return "MP3 recompression";
954 when xz_recomp => return "XZ recompression";
955 when jpeg_recomp => return "JPEG recompression";
956 when wavpack => return "WAVE recompression";
957 when ppmd => return "PPMd";
958 when unknown => return "(unknown)";
959 end case;
960 end Image;
961
962 function Method_from_Code (x : Natural) return PKZip_method is
963 -- An enumeration clause might be more elegant instead of this function,
964 -- but would need curiously an Unchecked_Conversion... (RM 13.4)
965 use Compression_format_code;
966 begin
967 case x is
968 when store_code => return store;
969 when shrink_code => return shrink;
970 when reduce_code => return reduce_1;
971 when reduce_code + 1 => return reduce_2;
972 when reduce_code + 2 => return reduce_3;
973 when reduce_code + 3 => return reduce_4;
974 when implode_code => return implode;
975 when tokenize_code => return tokenize;
976 when deflate_code => return deflate;
977 when deflate_e_code => return deflate_e;
978 when bzip2_code => return bzip2_meth;
979 when lzma_code => return lzma_meth;
980 when zstandard_code => return zstandard;
981 when mp3_code => return mp3_recomp;
982 when xz_code => return xz_recomp;
983 when jpeg_code => return jpeg_recomp;
984 when wavpack_code => return wavpack;
985 when ppmd_code => return ppmd;
986 when others => return unknown;
987 end case;
988 end Method_from_Code;
989
990 function Method_from_Code (x : Interfaces.Unsigned_16) return PKZip_method is
991 begin
992 return Method_from_Code (Natural (x));
993 end Method_from_Code;
994
995 -- Copy a chunk from a stream into another one, using a temporary buffer
996 procedure Copy_Chunk
997 (from : in out Zip_Streams.Root_Zipstream_Type'Class;
998 into : in out Ada.Streams.Root_Stream_Type'Class;
999 bytes : Natural;
1000 buffer_size : Positive := 1024 * 1024;
1001 Feedback : Feedback_Proc := null)
1002 is
1003 buf : Zip.Byte_Buffer (1 .. buffer_size);
1004 actually_read, remains : Natural;
1005 user_abort : Boolean := False;
1006 begin
1007 remains := bytes;
1008 while remains > 0 loop
1009 if Feedback /= null then
1010 Feedback (
1011 100 - Integer (100.0 * Float (remains) / Float (bytes)),
1012 False,
1013 user_abort
1014 );
1015 -- !! do something if user_abort = True !!
1016 end if;
1017 Zip.Block_Read (from, buf (1 .. Integer'Min (remains, buf'Last)), actually_read);
1018 if actually_read = 0 then -- premature end, unexpected
1019 raise Zip.Archive_corrupted;
1020 end if;
1021 remains := remains - actually_read;
1022 Zip.Block_Write (into, buf (1 .. actually_read));
1023 end loop;
1024 end Copy_Chunk;
1025
1026 -- Copy a whole file into a stream, using a temporary buffer
1027 procedure Copy_File
1028 (file_name : String;
1029 into : in out Ada.Streams.Root_Stream_Type'Class;
1030 buffer_size : Positive := 1024 * 1024)
1031 is
1032 use Ada.Streams.Stream_IO;
1033 f : File_Type;
1034 buf : Zip.Byte_Buffer (1 .. buffer_size);
1035 actually_read : Natural;
1036 begin
1037 Open (f, In_File, file_name);
1038 loop
1039 Zip.Block_Read (f, buf, actually_read);
1040 exit when actually_read = 0; -- this is expected
1041 Zip.Block_Write (into, buf (1 .. actually_read));
1042 end loop;
1043 Close (f);
1044 end Copy_File;
1045
1046 -- This does the same as Ada 2005's Ada.Directories.Exists
1047 -- Just there as helper for Ada 95 only systems
1048 --
1049 function Exists (file_name : String) return Boolean is
1050 use Ada.Text_IO, Ada.Strings.Fixed;
1051 f : File_Type;
1052 begin
1053 if Index (file_name, "*") > 0 then
1054 return False;
1055 end if;
1056 Open (f, In_File, file_name, Form => Ada.Strings.Unbounded.To_String (Zip_Streams.Form_For_IO_Open_and_Create));
1057 Close (f);
1058 return True;
1059 exception
1060 when Name_Error =>
1061 return False; -- The file cannot exist !
1062 when Use_Error =>
1063 return True; -- The file exists and is already opened !
1064 end Exists;
1065
1066 procedure Put_Multi_Line
1067 (out_file : Ada.Text_IO.File_Type;
1068 text : String)
1069 is
1070 last_char : Character := ' ';
1071 c : Character;
1072 begin
1073 for i in text'Range loop
1074 c := text (i);
1075 case c is
1076 when ASCII.CR =>
1077 Ada.Text_IO.New_Line (out_file);
1078 when ASCII.LF =>
1079 if last_char /= ASCII.CR then Ada.Text_IO.New_Line (out_file); end if;
1080 when others =>
1081 Ada.Text_IO.Put (out_file, c);
1082 end case;
1083 last_char := c;
1084 end loop;
1085 end Put_Multi_Line;
1086
1087 procedure Write_as_Text
1088 (out_file : Ada.Text_IO.File_Type;
1089 buffer : Byte_Buffer;
1090 last_char : in out Character) -- track line-ending characters across writes
1091 is
1092 c : Character;
1093 begin
1094 for i in buffer'Range loop
1095 c := Character'Val (buffer (i));
1096 case c is
1097 when ASCII.CR =>
1098 Ada.Text_IO.New_Line (out_file);
1099 when ASCII.LF =>
1100 if last_char /= ASCII.CR then Ada.Text_IO.New_Line (out_file); end if;
1101 when others =>
1102 Ada.Text_IO.Put (out_file, c);
1103 end case;
1104 last_char := c;
1105 end loop;
1106 end Write_as_Text;
1107
1108 function Hexadecimal (x : Interfaces.Unsigned_32) return String
1109 is
1110 package MIO is new Ada.Text_IO.Modular_IO (Interfaces.Unsigned_32);
1111 str : String (1 .. 12);
1112 use Ada.Strings.Fixed;
1113 begin
1114 MIO.Put (str, x, 16);
1115 return str (Index (str, "#") + 1 .. 11);
1116 end Hexadecimal;
1117
1118 overriding procedure Adjust (info : in out Zip_Info) is
1119
1120 function Tree_Clone (p : in p_Dir_node) return p_Dir_node is
1121 q : p_Dir_node;
1122 begin
1123 if p = null then
1124 return null;
1125 else
1126 q := new Dir_node'(p.all);
1127 q.left := Tree_Clone (p.left);
1128 q.right := Tree_Clone (p.right);
1129 return q;
1130 end if;
1131 end Tree_Clone;
1132
1133 begin
1134 info.dir_binary_tree := Tree_Clone (info.dir_binary_tree);
1135 info.zip_file_name := new String'(info.zip_file_name.all);
1136 info.zip_file_comment := new String'(info.zip_file_comment.all);
1137 end Adjust;
1138
1139 overriding procedure Finalize (info : in out Zip_Info) is
1140 begin
1141 Delete (info);
1142 end Finalize;
1143
1144 end Zip;
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.
