Source file : unzip.adb
1 -- Legal licensing note:
2
3 -- Copyright (c) 1999 .. 2023 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, UnZip.Decompress;
28 with Zip_Streams;
29
30 with Ada.IO_Exceptions;
31 with Interfaces;
32
33 package body UnZip is
34
35 use Ada.Strings.Unbounded, Interfaces;
36
37 boolean_to_encoding : constant array (Boolean) of Zip.Zip_Name_Encoding :=
38 (False => Zip.IBM_437, True => Zip.UTF_8);
39
40 fallback_compressed_size : constant := 16#FFFF_FFFF#;
41
42 --------------------------------------------------
43 -- *The* internal 1-file unzipping procedure. --
44 -- Input must be _open_ and won't be _closed_ ! --
45 --------------------------------------------------
46
47 procedure UnZipFile
48 (zip_file : in out Zip_Streams.Root_Zipstream_Type'Class;
49 out_name : String;
50 out_name_encoding : Zip.Zip_Name_Encoding;
51 name_from_header : Boolean;
52 header_index : in out Zip_Streams.ZS_Index_Type;
53 hint_comp_size : Zip.Zip_64_Data_Size_Type; -- Added 2007 for .ODS files
54 hint_crc_32 : Unsigned_32; -- Added 2012 for decryption
55 feedback : Zip.Feedback_Proc;
56 help_the_file_exists : Resolve_Conflict_Proc;
57 tell_data : Tell_Data_Proc;
58 get_pwd : Get_Password_Proc;
59 options : Option_Set;
60 password : in out Unbounded_String;
61 file_system_routines : FS_Routines_Type)
62 is
63 work_index : Zip_Streams.ZS_Index_Type := header_index;
64 local_header : Zip.Headers.Local_File_Header;
65 data_descriptor_after_data : Boolean;
66 method : PKZip_Method;
67
68 skip_this_file : Boolean := False;
69 bin_text_mode : constant array (Boolean) of Write_Mode_Type :=
70 (write_to_binary_file, write_to_text_file);
71 mode : constant array (Boolean) of Write_Mode_Type :=
72 (bin_text_mode (options (extract_as_text)), just_test);
73 actual_mode : Write_Mode_Type := mode (options (test_only));
74
75 true_packed_size : Zip.Zip_64_Data_Size_Type; -- encryption adds 12 to packed size
76
77 the_output_name : Unbounded_String;
78
79 -- 27-Jun-2001 : possibility of trashing directory part of a name
80 -- e.g. : zipada/uza_src/unzip.ads -> unzip.ads
81 function Maybe_trash_dir (n : String) return String is
82 idx : Integer := n'First - 1;
83 begin
84 if options (junk_directories) then
85 for i in n'Range loop
86 if n (i) in '/' | '\' then
87 idx := i;
88 end if;
89 end loop;
90 -- idx points on the index just before the interesting part
91 return n (idx + 1 .. n'Last);
92 else
93 return n;
94 end if;
95 end Maybe_trash_dir;
96
97 procedure Set_definitively_named_outfile (composed_name : String) is
98 idx : Integer := composed_name'First - 1;
99 first_in_name : Integer;
100 begin
101 for i in composed_name'Range loop
102 if composed_name (i) in '/' | '\' then
103 idx := i;
104 end if;
105 end loop;
106 -- idx points on the index just before the name part
107
108 if idx >= composed_name'First and then
109 actual_mode in Write_to_file and then
110 file_system_routines.Create_Path /= null
111 then
112 -- Not only the name, also a path.
113 -- In that case, we may need to create parts of the path.
114 declare
115 Directory_Separator : constant Character := '/';
116 -- The '/' separator is also recognized by Windows' routines,
117 -- so we can just use it as a standard. See the discussion started
118 -- in July 2010 in the Ada Comment mailing list about it
119 -- for the 2012 standard.
120 path : String := composed_name (composed_name'First .. idx - 1);
121 begin
122 -- Set the file separator recognized by the O.S.
123 for i in path'Range loop
124 if path (i) in '/' | '\' then
125 path (i) := Directory_Separator;
126 end if;
127 end loop;
128 if path = "" then
129 null;
130 elsif path (path'Last) = ':' then
131 null; -- We are on Windows and cannot create drives (like "D:")
132 else
133 file_system_routines.Create_Path (path);
134 end if;
135 end;
136 end if;
137 -- Now we can create the file itself.
138 first_in_name := composed_name'First;
139 --
140 the_output_name :=
141 To_Unbounded_String (composed_name (first_in_name .. composed_name'Last));
142 end Set_definitively_named_outfile;
143
144 function Full_Path_Name (
145 file_name_in_archive : String;
146 encoding : Zip.Zip_Name_Encoding)
147 return String
148 is
149 begin
150 if file_system_routines.Compose_File_Name = null then
151 return file_name_in_archive;
152 else
153 return file_system_routines.Compose_File_Name (file_name_in_archive, encoding);
154 end if;
155 end Full_Path_Name;
156
157 procedure Set_outfile (
158 long_not_composed_name : String;
159 encoding : Zip.Zip_Name_Encoding
160 )
161 is
162 -- Eventually trash the archived directory structure, then
163 -- eventually add/modify/... another one:
164 name : constant String :=
165 Full_Path_Name (Maybe_trash_dir (long_not_composed_name), encoding);
166 begin
167 Set_definitively_named_outfile (name);
168 end Set_outfile;
169
170 procedure Set_outfile_interactive (
171 long_not_composed_possible_name : String;
172 encoding : Zip.Zip_Name_Encoding
173 )
174 is
175 -- Eventually trash the archived directory structure, then
176 -- eventually add/modify/... another one:
177 possible_name : constant String :=
178 Full_Path_Name (Maybe_trash_dir (long_not_composed_possible_name), encoding);
179 -- possible_name may have a different encoding depending on Compose_File_Name...
180 new_name : String (1 .. 1024);
181 new_name_length : Natural;
182 begin
183 if help_the_file_exists /= null and then Zip.Exists (possible_name) then
184 loop
185 case current_user_attitude is
186 when yes | no | rename_it => -- then ask for this name too
187 help_the_file_exists (
188 long_not_composed_possible_name, encoding,
189 current_user_attitude,
190 new_name, new_name_length
191 );
192 when yes_to_all | none | abort_now =>
193 exit; -- nothing to decide: previous decision was definitive
194 end case;
195 exit when not (
196 current_user_attitude = rename_it and then -- new name exists too!
197 Zip.Exists (new_name (1 .. new_name_length))
198 );
199 end loop;
200
201 -- User has decided.
202 case current_user_attitude is
203 when yes | yes_to_all =>
204 skip_this_file := False;
205 Set_definitively_named_outfile (possible_name);
206 when no | none =>
207 skip_this_file := True;
208 when rename_it =>
209 skip_this_file := False;
210 Set_definitively_named_outfile (new_name (1 .. new_name_length));
211 when abort_now =>
212 raise User_abort;
213 end case;
214
215 else -- no name conflict or non-interactive (help_the_file_exists=null)
216
217 skip_this_file := False;
218 Set_definitively_named_outfile (possible_name);
219 end if;
220 end Set_outfile_interactive;
221
222 procedure Inform_User (
223 name : String;
224 comp, uncomp : Zip.Zip_64_Data_Size_Type
225 )
226 is
227 begin
228 if tell_data /= null then
229 tell_data (name, comp, uncomp, method);
230 end if;
231 end Inform_User;
232
233 the_name : String (1 .. 65_535); -- Seems overkill, but Zip entry names can be that long!
234 the_name_len : Natural;
235 use Zip_Streams;
236 use type Zip.PKZip_method;
237 use type Zip.Feedback_Proc;
238
239 actual_feedback : Zip.Feedback_Proc;
240
241 dummy_memory : p_Stream_Element_Array;
242 dummy_stream : constant p_Stream := null;
243 encrypted, dummy_bool : Boolean;
244
245 begin
246 begin
247 Set_Index (zip_file, work_index);
248 Zip.Headers.Read_and_Check (zip_file, local_header);
249 exception
250 when Zip.Headers.bad_local_header =>
251 raise; -- Processed later, on Extract
252 when others =>
253 raise Zip.Archive_corrupted;
254 end;
255
256 method := Zip.Method_from_Code (local_header.zip_type);
257 if method = Zip.unknown then
258 raise UnZip.Unsupported_method with
259 "Format (method) #" & Unsigned_16'Image (local_header.zip_type) &
260 " is unknown";
261 end if;
262
263 -- calculate offset of data
264
265 work_index :=
266 work_index +
267 ZS_Size_Type (
268 local_header.filename_length +
269 local_header.extra_field_length +
270 Zip.Headers.local_header_length
271 );
272
273 --
274 -- Zip64 extension.
275 --
276 if local_header.extra_field_length >= 4 then
277 declare
278 mem : constant Zip_Streams.ZS_Index_Type := Index (zip_file);
279 local_header_extension : Zip.Headers.Local_File_Header_Extension;
280 dummy_offset : Unsigned_64 := 0; -- Initialized for avoiding random value = 16#FFFF_FFFF#
281 begin
282 Set_Index (zip_file, mem + Zip_Streams.ZS_Index_Type (local_header.filename_length));
283 Zip.Headers.Read_and_Check (zip_file, local_header_extension);
284 Set_Index (zip_file, mem);
285 Zip.Headers.Interpret
286 (local_header_extension,
287 local_header.dd.uncompressed_size,
288 local_header.dd.compressed_size,
289 dummy_offset);
290 end;
291 end if;
292
293 data_descriptor_after_data := (local_header.bit_flag and 8) /= 0;
294
295 if data_descriptor_after_data then
296 -- Sizes and CRC are stored after the data
297 -- We set size to avoid getting a sudden Zip_EOF !
298 if local_header.zip_type = 0
299 and then hint_comp_size = fallback_compressed_size
300 then
301 -- For Stored (Method 0) data we need a correct "compressed" size.
302 -- If the hint is the bogus fallback value, it is better to trust
303 -- the local header, since this size is known in advance. Case found
304 -- in Microsoft's OneDrive cloud storage (in 2018). Zip files,
305 -- created by the server for downloading more than one file, are
306 -- using the "Store" format and a postfixed Data Descriptor for
307 -- writing the CRC value.
308 --
309 null; -- Do not overwrite the compressed size in that case.
310 else
311 local_header.dd.compressed_size := hint_comp_size;
312 end if;
313 local_header.dd.crc_32 := hint_crc_32;
314 local_header.dd.uncompressed_size := fallback_compressed_size;
315 actual_feedback := null; -- no feedback possible: unknown sizes
316 else
317 -- Sizes and CRC are stored before the data, inside the local header
318 actual_feedback := feedback; -- use the given feedback procedure
319 end if;
320
321 encrypted := (local_header.bit_flag and Zip.Headers.Encryption_Flag_Bit) /= 0;
322
323 -- 13-Dec-2002
324 true_packed_size := local_header.dd.compressed_size;
325 if encrypted then
326 true_packed_size := true_packed_size - 12;
327 end if;
328
329 if name_from_header then -- Name from local header is used as output name
330 the_name_len := Natural (local_header.filename_length);
331 if the_name_len > 0 then
332 String'Read (zip_file'Access, the_name (1 .. the_name_len));
333 end if;
334 if not data_descriptor_after_data then
335 Inform_User (
336 the_name (1 .. the_name_len),
337 true_packed_size,
338 local_header.dd.uncompressed_size
339 );
340 end if;
341 if the_name_len = 0 or else the_name (the_name_len) in '/' | '\' then
342 -- This is a directory name (12-feb-2000)
343 skip_this_file := True;
344 elsif actual_mode in Write_to_file then
345 Set_outfile_interactive (
346 the_name (1 .. the_name_len),
347 boolean_to_encoding ((local_header.bit_flag and
348 Zip.Headers.Language_Encoding_Flag_Bit) /= 0)
349 );
350 else -- only informational, no need for interaction
351 Set_outfile (the_name (1 .. the_name_len),
352 boolean_to_encoding ((local_header.bit_flag and
353 Zip.Headers.Language_Encoding_Flag_Bit) /= 0)
354 );
355 end if;
356 else -- Output name is given: out_name
357 if not data_descriptor_after_data then
358 Inform_User (
359 out_name,
360 true_packed_size,
361 local_header.dd.uncompressed_size
362 );
363 end if;
364 if out_name'Length = 0 or else out_name (out_name'Last) in '/' | '\' then
365 -- This is a directory name, so do not write anything (30-Jan-2012).
366 skip_this_file := True;
367 elsif actual_mode in Write_to_file then
368 Set_outfile_interactive (out_name, out_name_encoding);
369 else -- only informational, no need for interaction
370 Set_outfile (out_name, out_name_encoding);
371 end if;
372 end if;
373
374 if skip_this_file then
375 actual_mode := just_test;
376 end if;
377
378 if skip_this_file and not data_descriptor_after_data then
379 -- We can skip actually since sizes are known.
380 if feedback /= null then
381 feedback (
382 percents_done => 0,
383 entry_skipped => True,
384 user_abort => dummy_bool
385 );
386 end if;
387 else
388 begin
389 Set_Index (zip_file, work_index); -- eventually skips the file name
390 exception
391 when others =>
392 raise Zip.Archive_corrupted with
393 "End of stream reached (location: between local header and archived data)";
394 end;
395 UnZip.Decompress.Decompress_Data (
396 zip_file => zip_file,
397 format => method,
398 write_mode => actual_mode,
399 output_file_name => To_String (the_output_name),
400 output_memory_access => dummy_memory,
401 output_stream_access => dummy_stream,
402 feedback => actual_feedback,
403 explode_literal_tree => (local_header.bit_flag and 4) /= 0,
404 explode_slide_8KB_LZMA_EOS => (local_header.bit_flag and Zip.Headers.LZMA_EOS_Flag_Bit) /= 0,
405 data_descriptor_after_data => data_descriptor_after_data,
406 is_encrypted => encrypted,
407 password => password,
408 get_new_password => get_pwd,
409 hint => local_header
410 );
411
412 if actual_mode /= just_test then
413 begin
414 if file_system_routines.Set_Time_Stamp /= null then
415 file_system_routines.Set_Time_Stamp (
416 To_String (the_output_name),
417 Zip.Convert (local_header.file_timedate)
418 );
419 elsif file_system_routines.Set_ZTime_Stamp /= null then
420 file_system_routines.Set_ZTime_Stamp (
421 To_String (the_output_name),
422 local_header.file_timedate
423 );
424 end if;
425 exception
426 when Zip_Streams.Calendar.Time_Error | Ada.Calendar.Time_Error =>
427 null; -- invalid time, we give up setting the time stamp
428 end;
429 end if;
430
431 if data_descriptor_after_data then -- Sizes and CRC at the end
432 -- Inform after decompression
433 Inform_User (
434 To_String (the_output_name),
435 local_header.dd.compressed_size,
436 local_header.dd.uncompressed_size
437 );
438 end if;
439
440 end if; -- not ( skip_this_file and not data_descriptor )
441
442 -- Set the offset on the next zipped file
443 header_index := header_index +
444 ZS_Size_Type (
445 local_header.filename_length +
446 local_header.extra_field_length +
447 Zip.Headers.local_header_length
448 ) +
449 ZS_Size_Type (local_header.dd.compressed_size);
450
451 if data_descriptor_after_data then
452 header_index :=
453 header_index + ZS_Size_Type (Zip.Headers.data_descriptor_length);
454 end if;
455
456 exception
457 when Ada.IO_Exceptions.End_Error =>
458 raise Zip.Archive_corrupted with "End of stream reached";
459 end UnZipFile;
460
461 ----------------------------------
462 -- Simple extraction procedures --
463 ----------------------------------
464
465 -- Extract all files from an archive (from)
466
467 procedure Extract (from : String;
468 options : Option_Set := no_option;
469 password : String := "";
470 file_system_routines : FS_Routines_Type := null_routines)
471 is
472 begin
473 Extract (from, null, null, null, null,
474 options, password, file_system_routines);
475 end Extract;
476
477 procedure Extract (from : String;
478 what : String;
479 options : Option_Set := no_option;
480 password : String := "";
481 file_system_routines : FS_Routines_Type := null_routines)
482 is
483 begin
484 Extract (from, what, null, null, null, null,
485 options, password, file_system_routines);
486 end Extract;
487
488 procedure Extract (from : String;
489 what : String;
490 rename : String;
491 options : Option_Set := no_option;
492 password : String := "";
493 file_system_routines : FS_Routines_Type := null_routines)
494 is
495 begin
496 Extract (from, what, rename, null, null, null,
497 options, password, file_system_routines);
498 end Extract;
499
500 procedure Extract (from : Zip.Zip_Info;
501 options : Option_Set := no_option;
502 password : String := "";
503 file_system_routines : FS_Routines_Type := null_routines)
504 is
505 begin
506 Extract (from, null, null, null, null,
507 options, password, file_system_routines);
508 end Extract;
509
510 procedure Extract (from : Zip.Zip_Info;
511 what : String;
512 options : Option_Set := no_option;
513 password : String := "";
514 file_system_routines : FS_Routines_Type := null_routines)
515 is
516 begin
517 Extract (from, what, null, null, null, null,
518 options, password, file_system_routines);
519 end Extract;
520
521 procedure Extract (from : Zip.Zip_Info;
522 what : String;
523 rename : String;
524 options : Option_Set := no_option;
525 password : String := "";
526 file_system_routines : FS_Routines_Type := null_routines)
527 is
528 begin
529 Extract (from, what, rename, null, null, null,
530 options, password, file_system_routines);
531 end Extract;
532
533 -- All previous extract call the following ones, with bogus UI arguments
534
535 ------------------------------------------------------------
536 -- All previous extraction procedures, for user interface --
537 ------------------------------------------------------------
538
539 -- Extract one precise file (what) from an archive (from)
540
541 procedure Extract (from : String;
542 what : String;
543 feedback : Zip.Feedback_Proc;
544 help_the_file_exists : Resolve_Conflict_Proc;
545 tell_data : Tell_Data_Proc;
546 get_pwd : Get_Password_Proc;
547 options : Option_Set := no_option;
548 password : String := "";
549 file_system_routines : FS_Routines_Type := null_routines)
550 is
551 use Zip_Streams;
552 use type Zip.Feedback_Proc;
553 zip_file : File_Zipstream;
554 header_index : ZS_Index_Type;
555 comp_size : Zip.Zip_64_Data_Size_Type;
556 uncomp_size : Zip.Zip_64_Data_Size_Type;
557 crc_32 : Unsigned_32;
558 work_password : Unbounded_String := To_Unbounded_String (password);
559 begin
560 if feedback = null then
561 current_user_attitude := yes_to_all; -- non-interactive
562 end if;
563 Set_Name (zip_file, from);
564 Open (zip_file, In_File);
565 Zip.Find_Offset
566 (file => zip_file,
567 name => what,
568 case_sensitive => options (case_sensitive_match),
569 file_index => header_index,
570 comp_size => comp_size,
571 uncomp_size => uncomp_size,
572 crc_32 => crc_32);
573 --
574 UnZipFile
575 (zip_file => zip_file,
576 out_name => what,
577 out_name_encoding => Zip.IBM_437, -- assumption...
578 name_from_header => False,
579 header_index => header_index,
580 hint_comp_size => comp_size,
581 hint_crc_32 => crc_32,
582 feedback => feedback,
583 help_the_file_exists => help_the_file_exists,
584 tell_data => tell_data,
585 get_pwd => get_pwd,
586 options => options,
587 password => work_password,
588 file_system_routines => file_system_routines);
589 --
590 Close (zip_file);
591 exception
592 when Zip.Headers.bad_local_header =>
593 raise Zip.Archive_corrupted with "Bad local header";
594 end Extract;
595
596 -- Extract one precise file (what) from an archive (from),
597 -- but save under a new name (rename)
598
599 procedure Extract (from : String;
600 what : String;
601 rename : String;
602 feedback : Zip.Feedback_Proc;
603 tell_data : Tell_Data_Proc;
604 get_pwd : Get_Password_Proc;
605 options : Option_Set := no_option;
606 password : String := "";
607 file_system_routines : FS_Routines_Type := null_routines)
608 is
609 use Zip_Streams;
610 use type Zip.Feedback_Proc;
611 zip_file : aliased File_Zipstream;
612 header_index : Zip_Streams.ZS_Index_Type;
613 comp_size : Zip.Zip_64_Data_Size_Type;
614 uncomp_size : Zip.Zip_64_Data_Size_Type;
615 crc_32 : Unsigned_32;
616 work_password : Unbounded_String := To_Unbounded_String (password);
617 begin
618 if feedback = null then
619 current_user_attitude := yes_to_all; -- non-interactive
620 end if;
621 Set_Name (zip_file, from);
622 Open (zip_file, In_File);
623 Zip.Find_Offset
624 (file => zip_file,
625 name => what,
626 case_sensitive => options (case_sensitive_match),
627 file_index => header_index,
628 comp_size => comp_size,
629 uncomp_size => uncomp_size,
630 crc_32 => crc_32);
631 --
632 UnZipFile
633 (zip_file => zip_file,
634 out_name => rename,
635 out_name_encoding => Zip.IBM_437, -- assumption...
636 name_from_header => False,
637 header_index => header_index,
638 hint_comp_size => comp_size,
639 hint_crc_32 => crc_32,
640 feedback => feedback,
641 help_the_file_exists => null,
642 tell_data => tell_data,
643 get_pwd => get_pwd,
644 options => options,
645 password => work_password,
646 file_system_routines => file_system_routines);
647 --
648 Close (zip_file);
649 exception
650 when Zip.Headers.bad_local_header =>
651 raise Zip.Archive_corrupted with "Bad local header";
652 end Extract;
653
654 -- Extract all files from an archive (from)
655
656 procedure Extract (from : String;
657 feedback : Zip.Feedback_Proc;
658 help_the_file_exists : Resolve_Conflict_Proc;
659 tell_data : Tell_Data_Proc;
660 get_pwd : Get_Password_Proc;
661 options : Option_Set := no_option;
662 password : String := "";
663 file_system_routines : FS_Routines_Type := null_routines)
664 is
665 use Zip_Streams;
666 use type Zip.Feedback_Proc;
667 zip_file : File_Zipstream;
668 header_index : Zip_Streams.ZS_Index_Type;
669 work_password : Unbounded_String := To_Unbounded_String (password);
670 begin
671 if feedback = null then
672 current_user_attitude := yes_to_all; -- non-interactive
673 end if;
674 Set_Name (zip_file, from);
675 Open (zip_file, In_File);
676 Zip.Find_first_Offset (zip_file, header_index); -- >= 13-May-2001
677 -- We simply unzip everything sequentially, until the end:
678 all_files : loop
679 UnZipFile
680 (zip_file => zip_file,
681 out_name => "",
682 out_name_encoding => Zip.IBM_437, -- ignored
683 name_from_header => True,
684 header_index => header_index,
685 hint_comp_size => fallback_compressed_size,
686 -- ^ no better hint available if comp_size is 0 in local header
687 hint_crc_32 => 0, -- 2.0 decryption can fail if data descriptor after data
688 feedback => feedback,
689 help_the_file_exists => help_the_file_exists,
690 tell_data => tell_data,
691 get_pwd => get_pwd,
692 options => options,
693 password => work_password,
694 file_system_routines => file_system_routines);
695 end loop all_files;
696 exception
697 when Zip.Headers.bad_local_header | Zip.Archive_is_empty =>
698 Close (zip_file); -- Normal case: end of archived entries (of fuzzy data) was hit
699 when Zip.Archive_open_error =>
700 raise; -- Couldn't open zip file
701 when others =>
702 Close (zip_file);
703 raise; -- Something else went wrong
704 end Extract;
705
706 -- Extract all files from an archive (from)
707 -- Needs Zip.Load(from, ...) prior to the extraction
708
709 procedure Extract (from : Zip.Zip_Info;
710 feedback : Zip.Feedback_Proc;
711 help_the_file_exists : Resolve_Conflict_Proc;
712 tell_data : Tell_Data_Proc;
713 get_pwd : Get_Password_Proc;
714 options : Option_Set := no_option;
715 password : String := "";
716 file_system_routines : FS_Routines_Type := null_routines)
717 is
718 procedure Extract_1_file (name : String) is
719 begin
720 Extract
721 (from => from,
722 what => name,
723 feedback => feedback,
724 help_the_file_exists => help_the_file_exists,
725 tell_data => tell_data,
726 get_pwd => get_pwd,
727 options => options,
728 password => password,
729 file_system_routines => file_system_routines);
730 end Extract_1_file;
731 --
732 procedure Extract_all_files is new Zip.Traverse (Extract_1_file);
733 --
734 begin
735 Extract_all_files (from);
736 end Extract;
737
738 -- Extract one precise file (what) from an archive (from)
739 -- Needs Zip.Load(from, ...) prior to the extraction
740
741 procedure Extract (from : Zip.Zip_Info;
742 what : String;
743 feedback : Zip.Feedback_Proc;
744 help_the_file_exists : Resolve_Conflict_Proc;
745 tell_data : Tell_Data_Proc;
746 get_pwd : Get_Password_Proc;
747 options : Option_Set := no_option;
748 password : String := "";
749 file_system_routines : FS_Routines_Type := null_routines
750 ) is
751
752 header_index : Zip_Streams.ZS_Index_Type;
753 comp_size : Zip.Zip_64_Data_Size_Type;
754 uncomp_size : Zip.Zip_64_Data_Size_Type;
755 crc_32 : Unsigned_32;
756 work_password : Unbounded_String := To_Unbounded_String (password);
757 use Zip_Streams;
758 use type Zip.Feedback_Proc;
759 zip_file : aliased File_Zipstream;
760 input_stream : Zipstream_Class_Access;
761 use_a_file : constant Boolean := Zip.Zip_Stream (from) = null;
762 name_encoding : Zip.Zip_Name_Encoding;
763 begin
764 if use_a_file then
765 input_stream := zip_file'Unchecked_Access;
766 Set_Name (zip_file, Zip.Zip_Name (from));
767 Open (zip_file, In_File);
768 else -- use the given stream
769 input_stream := Zip.Zip_Stream (from);
770 end if;
771 if feedback = null then
772 current_user_attitude := yes_to_all; -- non-interactive
773 end if;
774 Zip.Find_Offset
775 (info => from,
776 name => what,
777 name_encoding => name_encoding,
778 file_index => header_index,
779 comp_size => comp_size,
780 uncomp_size => uncomp_size,
781 crc_32 => crc_32);
782 --
783 UnZipFile
784 (zip_file => input_stream.all,
785 out_name => what,
786 out_name_encoding => name_encoding,
787 name_from_header => False,
788 header_index => header_index,
789 hint_comp_size => comp_size,
790 hint_crc_32 => crc_32,
791 feedback => feedback,
792 help_the_file_exists => help_the_file_exists,
793 tell_data => tell_data,
794 get_pwd => get_pwd,
795 options => options,
796 password => work_password,
797 file_system_routines => file_system_routines);
798 --
799 if use_a_file then
800 Close (zip_file);
801 end if;
802 exception
803 when Zip.Headers.bad_local_header =>
804 if use_a_file and then Is_Open (zip_file) then
805 Close (zip_file);
806 end if;
807 raise Zip.Archive_corrupted with "Bad local header";
808 when others =>
809 if use_a_file and then Is_Open (zip_file) then
810 Close (zip_file);
811 end if;
812 raise;
813 end Extract;
814
815 -- Extract one precise file (what) from an archive (from)
816 -- but save under a new name (rename)
817 -- Needs Zip.Load(from, ...) prior to the extraction
818
819 procedure Extract (from : Zip.Zip_Info;
820 what : String;
821 rename : String;
822 feedback : Zip.Feedback_Proc;
823 tell_data : Tell_Data_Proc;
824 get_pwd : Get_Password_Proc;
825 options : Option_Set := no_option;
826 password : String := "";
827 file_system_routines : FS_Routines_Type := null_routines)
828 is
829
830 header_index : Zip_Streams.ZS_Index_Type;
831 comp_size : Zip.Zip_64_Data_Size_Type;
832 uncomp_size : Zip.Zip_64_Data_Size_Type;
833 crc_32 : Unsigned_32;
834 work_password : Unbounded_String := To_Unbounded_String (password);
835 use Zip_Streams;
836 use type Zip.Feedback_Proc;
837 zip_file : aliased File_Zipstream;
838 input_stream : Zipstream_Class_Access;
839 use_a_file : constant Boolean := Zip.Zip_Stream (from) = null;
840 name_encoding : Zip.Zip_Name_Encoding;
841 begin
842 if use_a_file then
843 input_stream := zip_file'Unchecked_Access;
844 Set_Name (zip_file, Zip.Zip_Name (from));
845 Open (zip_file, In_File);
846 else -- use the given stream
847 input_stream := Zip.Zip_Stream (from);
848 end if;
849 if feedback = null then
850 current_user_attitude := yes_to_all; -- non-interactive
851 end if;
852 Zip.Find_Offset
853 (info => from,
854 name => what,
855 name_encoding => name_encoding,
856 file_index => header_index,
857 comp_size => comp_size,
858 uncomp_size => uncomp_size,
859 crc_32 => crc_32);
860 --
861 UnZipFile
862 (zip_file => input_stream.all,
863 out_name => rename,
864 out_name_encoding => name_encoding, -- assumption: encoding same as name
865 name_from_header => False,
866 header_index => header_index,
867 hint_comp_size => comp_size,
868 hint_crc_32 => crc_32,
869 feedback => feedback,
870 help_the_file_exists => null,
871 tell_data => tell_data,
872 get_pwd => get_pwd,
873 options => options,
874 password => work_password,
875 file_system_routines => file_system_routines);
876 --
877 if use_a_file then
878 Close (zip_file);
879 end if;
880 exception
881 when Zip.Headers.bad_local_header =>
882 if use_a_file and then Is_Open (zip_file) then
883 Close (zip_file);
884 end if;
885 raise Zip.Archive_corrupted with "Bad local header";
886 when others =>
887 if use_a_file and then Is_Open (zip_file) then
888 Close (zip_file);
889 end if;
890 raise;
891 end Extract;
892
893 end UnZip;
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.
