Source file : zip-create.adb
1 -- Legal licensing note:
2
3 -- Copyright (c) 2008 .. 2023 Gautier de Montmollin (maintenance and further development)
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 21-Aug-2016 on the site
25 -- http://www.opensource.org/licenses/mit-license.php
26
27 with Ada.Directories,
28 Ada.IO_Exceptions,
29 Ada.Text_IO,
30 Ada.Unchecked_Deallocation;
31
32 package body Zip.Create is
33
34 use Interfaces, Zip.Headers;
35
36 procedure Create_Archive (
37 Info : out Zip_Create_Info;
38 Z_Stream : in Zip_Streams.Zipstream_Class_Access;
39 Archive_Name : String;
40 Compress_Method : Zip.Compress.Compression_Method := Zip.Compress.Deflate_1;
41 Duplicates : Duplicate_name_policy := admit_duplicates
42 )
43 is
44 begin
45 Info.Stream := Z_Stream;
46 Info.Compress := Compress_Method;
47 if Archive_Name /= "" then
48 Info.Stream.Set_Name (Archive_Name);
49 end if;
50 --
51 -- If we have a real file (File_Zipstream or descendent), create the file too:
52 --
53 if Z_Stream.all in Zip_Streams.File_Zipstream'Class then
54 Zip_Streams.File_Zipstream (Z_Stream.all).Create (Zip_Streams.Out_File);
55 end if;
56 Info.Duplicates := Duplicates;
57 Info.zip_archive_format := Zip_32;
58 end Create_Archive;
59
60 function Is_Created (Info : Zip_Create_Info) return Boolean is
61 use type Zip_Streams.Zipstream_Class_Access;
62 begin
63 return Info.Stream /= null;
64 end Is_Created;
65
66 procedure Set (Info : in out Zip_Create_Info;
67 New_Method : Zip.Compress.Compression_Method)
68 is
69 begin
70 Info.Compress := New_Method;
71 end Set;
72
73 function Name (Info : Zip_Create_Info) return String is
74 begin
75 return Info.Stream.Get_Name;
76 end Name;
77
78 procedure Dispose is new
79 Ada.Unchecked_Deallocation (Dir_entries, Pdir_entries);
80
81 procedure Resize (A : in out Pdir_entries;
82 Size : Integer_M32) is
83 Hlp : constant Pdir_entries := new Dir_entries (1 .. Size);
84 begin
85 if A = null then
86 A := Hlp;
87 else
88 Hlp (1 .. Integer_M32'Min (Size, A'Length)) :=
89 A (1 .. Integer_M32'Min (Size, A'Length));
90 Dispose (A);
91 A := Hlp;
92 end if;
93 end Resize;
94
95 -- Internal - add the catalogue entry corresponding to a
96 -- compressed file in the Zip archive.
97 -- The entire catalogue will be written at the end of the zip stream,
98 -- and the entry as a local header just before the compressed data.
99 -- The entry's is mostly incomplete in the end (name, size, ...); stream
100 -- operations on the archive being built are not performed here,
101 -- see Add_Stream for that.
102 --
103 procedure Add_catalogue_entry (Info : in out Zip_Create_Info)
104 is
105 begin
106 if Info.Last_entry = 0 then
107 Info.Last_entry := 1;
108 Resize (Info.Contains, 32);
109 else
110 if Info.Last_entry = 2 ** 31 - 1 then
111 raise Zip_Capacity_Exceeded with
112 "Too many entries: more than 2,147,483,647.";
113 end if;
114 Info.Last_entry := Info.Last_entry + 1;
115 if Info.Last_entry > Info.Contains'Last then
116 -- Info.Contains is full, time to resize it!
117 -- We do nothing less than double the size - better than
118 -- whatever offer you'd get in your e-mails.
119 Resize (Info.Contains, Info.Contains'Last * 2);
120 end if;
121 end if;
122 declare
123 cfh : Central_File_Header renames Info.Contains (Info.Last_entry).head;
124 begin
125 -- Administration
126 cfh.made_by_version := 23; -- version 2.30
127 cfh.comment_length := 0;
128 cfh.disk_number_start := 0;
129 cfh.internal_attributes := 0; -- 0: binary; 1: text
130 cfh.external_attributes := 0;
131 cfh.short_info.needed_extract_version := 10; -- Value put by Zip/PKZip
132 cfh.short_info.bit_flag := 0;
133 end;
134 end Add_catalogue_entry;
135
136 -- This is just for detecting duplicates
137 procedure Insert_to_name_dictionary (file_name : String; m : in out Name_mapping.Map) is
138 cm : Name_mapping.Cursor;
139 OK : Boolean;
140 begin
141 m.Insert (Ada.Strings.Unbounded.To_Unbounded_String (file_name), cm, OK);
142 if not OK then -- Name already registered
143 raise Duplicate_name with "Entry name = " & file_name;
144 end if;
145 end Insert_to_name_dictionary;
146
147 procedure Add_Stream (Info : in out Zip_Create_Info;
148 Stream : in out Zip_Streams.Root_Zipstream_Type'Class;
149 Password : in String := "")
150 is
151 Compressed_Size : Zip.Zip_64_Data_Size_Type; -- dummy
152 Final_Method : Natural; -- dummy
153 begin
154 Add_Stream (Info, Stream, null, Password, Compressed_Size, Final_Method);
155 end Add_Stream;
156
157 four_GiB : constant := 4 * (1024 ** 3); -- = 2 ** 32
158
159 use Zip.Compress;
160
161 procedure Check_Size
162 (info : in out Zip_Create_Info;
163 value : in Zip_Streams.ZS_Size_Type) -- Archive index or input stream size
164 is
165 margin : constant := end_of_central_dir_length +
166 zip_64_end_of_central_dir_length +
167 zip_64_end_of_central_dir_locator_length +
168 2 ** 16 + -- Zip archive comment
169 10; -- Unknown unknown...
170 begin
171 if info.zip_archive_format = Zip_32 and then value >= four_GiB - margin then
172 -- Promote format to Zip_64 (entry size or cumulated archive size too large for Zip_32).
173 info.zip_archive_format := Zip_64;
174 if value >= max_size - margin then
175 raise Zip_Capacity_Exceeded with
176 "Archive too large: size is 2 EiB (Exbibytes) or more.";
177 end if;
178 end if;
179 end Check_Size;
180
181 function Unixify (entry_name : String) return String is
182 unixified : String (entry_name'Range) := entry_name;
183 begin
184 -- Appnote.txt, V. J. :
185 -- " All slashes should be forward slashes '/' as opposed to backwards slashes '\' "
186 for i in unixified'Range loop
187 if unixified (i) = '\' then
188 unixified (i) := '/';
189 end if;
190 end loop;
191 return unixified;
192 end Unixify;
193
194 procedure Add_Stream (Info : in out Zip_Create_Info;
195 Stream : in out Zip_Streams.Root_Zipstream_Type'Class;
196 Feedback : in Feedback_Proc;
197 Password : in String := "";
198 Compressed_Size : out Zip.Zip_64_Data_Size_Type;
199 Final_Method : out Natural)
200 is
201 mem1, mem2 : Zip_Streams.ZS_Index_Type := 1;
202 entry_name : constant String := Unixify (Stream.Get_Name);
203 Last : Positive_M32;
204 fh_extra : Local_File_Header_Extension;
205 begin
206 if Info.Duplicates = error_on_duplicate then
207 -- Check for duplicates; raises Duplicate_name in this case.
208 Insert_to_name_dictionary (entry_name, Info.name_dictionary);
209 end if;
210 Add_catalogue_entry (Info);
211 Last := Info.Last_entry;
212 declare
213 cfh : Central_File_Header renames Info.Contains (Last).head;
214 shi : Local_File_Header renames cfh.short_info;
215 extra_field_policy : Extra_Field_Policy_Kind;
216 begin
217 -- Administration - continued
218 if Zip_Streams.Is_Unicode_Name (Stream) then
219 shi.bit_flag := shi.bit_flag or Zip.Headers.Language_Encoding_Flag_Bit;
220 end if;
221 if Password /= "" then
222 shi.bit_flag := shi.bit_flag or Zip.Headers.Encryption_Flag_Bit;
223 end if;
224 if Stream.Is_Read_Only then
225 cfh.external_attributes := cfh.external_attributes or 1;
226 end if;
227 Info.Contains (Last).name := new String'(entry_name);
228 Check_Size (Info, Stream.Size);
229 shi.file_timedate := Stream.Get_Time;
230 shi.dd.uncompressed_size := Unsigned_64 (Stream.Size);
231 shi.dd.compressed_size := shi.dd.uncompressed_size;
232 shi.filename_length := entry_name'Length;
233 shi.extra_field_length := 0;
234
235 mem1 := Info.Stream.Index;
236 cfh.local_header_offset := Unsigned_64 (mem1) - 1;
237 if Needs_Local_Zip_64_Header_Extension (shi, cfh.local_header_offset) then
238 extra_field_policy := force_zip_64;
239 else
240 extra_field_policy := force_empty;
241 end if;
242 -- Write the local header with incomplete informations
243 Zip.Headers.Write (Info.Stream.all, shi, extra_field_policy);
244
245 String'Write (Info.Stream, entry_name);
246 if extra_field_policy = force_zip_64 then
247 -- Partial garbage. The extra field is rewritten later.
248 fh_extra.tag := 1;
249 fh_extra.size := local_header_extension_short_length - 4;
250 Zip.Headers.Write (Info.Stream.all, fh_extra, True);
251 end if;
252
253 Zip.Compress.Compress_Data
254 (input => Stream,
255 output => Info.Stream.all,
256 input_size_known => True,
257 input_size => shi.dd.uncompressed_size,
258 method => Info.Compress,
259 feedback => Feedback,
260 password => Password,
261 content_hint => Guess_Type_from_Name (entry_name),
262 CRC => shi.dd.crc_32,
263 output_size => shi.dd.compressed_size,
264 zip_type => shi.zip_type
265 );
266 if shi.zip_type = Compression_format_code.lzma_code then
267 --
268 -- For LZMA, we always put an EOS marker. From PKWARE's Appnote:
269 --
270 -- 5.8.9 Data compressed with method 14, LZMA, may include an end-of-stream
271 -- (EOS) marker ending the compressed data stream. This marker is not
272 -- required, but its use is highly recommended to facilitate processing
273 -- and implementers should include the EOS marker whenever possible.
274 -- When the EOS marker is used, general purpose bit 1 must be set. If
275 -- general purpose bit 1 is not set, the EOS marker is not present.
276 --
277 shi.bit_flag := shi.bit_flag or LZMA_EOS_Flag_Bit;
278 end if;
279 mem2 := Info.Stream.Index;
280 -- Go back to the local header to rewrite it with complete informations
281 -- known after the compression: CRC value, compressed size, actual compression format.
282 Info.Stream.Set_Index (mem1);
283 Zip.Headers.Write (Info.Stream.all, shi, extra_field_policy);
284 if extra_field_policy = force_zip_64 then
285 String'Write (Info.Stream, entry_name);
286 fh_extra.value_64 (1) := shi.dd.uncompressed_size;
287 fh_extra.value_64 (2) := shi.dd.compressed_size;
288 fh_extra.value_64 (3) := cfh.local_header_offset; -- Not actually written.
289 Zip.Headers.Write (Info.Stream.all, fh_extra, True);
290 end if;
291 -- Return to momentaneous end of file
292 Info.Stream.Set_Index (mem2);
293 --
294 Compressed_Size := shi.dd.compressed_size;
295 Final_Method := Natural (shi.zip_type);
296 end;
297 end Add_Stream;
298
299 procedure Add_File (Info : in out Zip_Create_Info;
300 File_Name : String;
301 -- Name_in_archive: default: add the file in
302 -- the archive under the File's name.
303 Name_in_archive : String := "";
304 -- Delete_file_after: practical to delete temporary file after adding.
305 Delete_file_after : Boolean := False;
306 Name_encoding : Zip_Name_Encoding := IBM_437;
307 -- Time stamp for this entry
308 Modification_time : Time := default_creation_time;
309 Is_read_only : Boolean := False;
310 Feedback : Feedback_Proc := null;
311 Password : String := ""
312 )
313 is
314 temp_zip_stream : aliased Zip_Streams.File_Zipstream;
315 file_for_deletion : Ada.Text_IO.File_Type;
316 Compressed_Size : Zip.Zip_64_Data_Size_Type; -- unused
317 Final_Method : Natural; -- unused
318 use type Zip_Streams.Time;
319 begin
320 -- Read the file
321 temp_zip_stream.Set_Name (Unixify (File_Name));
322 temp_zip_stream.Open (Zip_Streams.In_File);
323 -- Eventually we set a new name for archiving:
324 if Name_in_archive /= "" then
325 temp_zip_stream.Set_Name (Unixify (Name_in_archive));
326 end if;
327 temp_zip_stream.Set_Unicode_Name_Flag (Name_encoding = UTF_8);
328 temp_zip_stream.Set_Read_Only_Flag (Is_read_only);
329 if Modification_time = use_file_modification_time then
330 temp_zip_stream.Set_Time
331 (Ada.Directories.Modification_Time (File_Name));
332 elsif Modification_time = use_clock then
333 temp_zip_stream.Set_Time (Ada.Calendar.Clock);
334 else
335 temp_zip_stream.Set_Time (Modification_time);
336 end if;
337 -- Stuff into the .zip archive:
338 Add_Stream (Info, temp_zip_stream, Feedback, Password, Compressed_Size, Final_Method);
339 temp_zip_stream.Close;
340 if Delete_file_after then
341 Ada.Text_IO.Open (file_for_deletion, Ada.Text_IO.In_File, File_Name);
342 Ada.Text_IO.Delete (file_for_deletion);
343 end if;
344 exception
345 when User_abort =>
346 if temp_zip_stream.Is_Open then
347 temp_zip_stream.Close;
348 end if;
349 raise;
350 end Add_File;
351
352 procedure Add_String (Info : in out Zip_Create_Info;
353 Contents : String;
354 Name_in_archive : String;
355 -- Name_UTF_8_encoded = True if Name is actually UTF-8 encoded (Unicode)
356 Name_UTF_8_encoded : Boolean := False;
357 Password : String := "";
358 -- Time stamp for this entry
359 Creation_time : Zip.Time := default_creation_time
360 )
361 is
362 begin
363 Add_String (
364 Info => Info,
365 Contents => Ada.Strings.Unbounded.To_Unbounded_String (Contents),
366 Name_in_archive => Name_in_archive,
367 Name_UTF_8_encoded => Name_UTF_8_encoded,
368 Password => Password,
369 Creation_time => Creation_time
370 );
371 end Add_String;
372
373 procedure Add_String (Info : in out Zip_Create_Info;
374 Contents : Ada.Strings.Unbounded.Unbounded_String;
375 Name_in_archive : String;
376 -- Name_UTF_8_encoded = True if Name is actually UTF-8 encoded (Unicode)
377 Name_UTF_8_encoded : Boolean := False;
378 Password : String := "";
379 -- Time stamp for this entry
380 Creation_time : Zip.Time := default_creation_time
381 )
382 is
383 temp_zip_stream : Zip_Memory_Stream;
384 use type Zip_Streams.Time;
385 begin
386 temp_zip_stream.Set (Contents);
387 temp_zip_stream.Set_Name (Unixify (Name_in_archive));
388 if Creation_time = use_clock
389 -- If we have use_file_modification_time by mistake, use clock as well:
390 or else Creation_time = use_file_modification_time
391 then
392 temp_zip_stream.Set_Time (Ada.Calendar.Clock);
393 else
394 temp_zip_stream.Set_Time (Creation_time);
395 end if;
396 temp_zip_stream. Set_Unicode_Name_Flag (Name_UTF_8_encoded);
397 Add_Stream (Info, temp_zip_stream, Password);
398 end Add_String;
399
400 procedure Add_Empty_Folder
401 (Info : in out Zip_Create_Info;
402 Folder_Name : in String;
403 -- Name_UTF_8_encoded = True if Name is actually UTF-8 encoded (Unicode)
404 Name_UTF_8_encoded : in Boolean := False)
405 is
406 ufn : constant String := Unixify (Folder_Name);
407 begin
408 Add_String
409 (Info => Info,
410 Contents => "",
411 Name_UTF_8_encoded => Name_UTF_8_encoded,
412 Name_in_archive =>
413 (if ufn'Length > 0 and then ufn (ufn'Last) = '/'
414 then
415 ufn
416 else
417 ufn & '/'));
418 end Add_Empty_Folder;
419
420 procedure Add_Compressed_Stream
421 (Info : in out Zip_Create_Info; -- Destination
422 Stream : in out Zip_Streams.Root_Zipstream_Type'Class; -- Source
423 Feedback : in Feedback_Proc)
424 is
425 lh : Zip.Headers.Local_File_Header;
426 data_descriptor_after_data : Boolean;
427 offset : Unsigned_64;
428 begin
429 Zip.Headers.Read_and_Check (Stream, lh);
430 data_descriptor_after_data := (lh.bit_flag and 8) /= 0;
431 -- Copy name and extra field
432 declare
433 name : String (1 .. Positive (lh.filename_length));
434 extra : String (1 .. Natural (lh.extra_field_length));
435 begin
436 String'Read (Stream'Access, name);
437 String'Read (Stream'Access, extra);
438 if Info.Duplicates = error_on_duplicate then
439 -- Check for duplicates; raises Duplicate_name in this case:
440 Insert_to_name_dictionary (name, Info.name_dictionary);
441 end if;
442 Add_catalogue_entry (Info);
443 offset := Unsigned_64 (Info.Stream.Index) - 1;
444 Info.Contains (Info.Last_entry).head.local_header_offset := offset;
445 Info.Contains (Info.Last_entry).name := new String'(name);
446 -- Copy local header to new stream.
447 -- Extra field, zip_64 or another kind, is copied.
448 Zip.Headers.Write (Info.Stream.all, lh, from_header);
449 -- Copy entry name to new stream:
450 String'Write (Info.Stream, name);
451 -- Copy extra field to new stream, usually a Zip64 field:
452 String'Write (Info.Stream, extra);
453 end;
454 Zip.Copy_Chunk (
455 Stream,
456 Info.Stream.all,
457 Integer (lh.dd.compressed_size),
458 Feedback => Feedback
459 );
460 -- Postfixed data descriptor contains the correct values for
461 -- CRC and sizes. Example of Zip files using that descriptor: those
462 -- created by Microsoft's OneDrive cloud storage (for downloading
463 -- more than one file), in 2018.
464 if data_descriptor_after_data then
465 -- NB: some faulty JAR files may fail with Read_and_check.
466 -- See UnZip.Decompress, Process_descriptor.
467 Zip.Headers.Read_and_Check (Stream, lh.dd);
468 -- lh's values have been corrected on the way.
469 Zip.Headers.Write (Info.Stream.all, lh.dd); -- Copy descriptor to new stream.
470 end if;
471 Info.Contains (Info.Last_entry).head.short_info := lh;
472 end Add_Compressed_Stream;
473
474 use Ada.Streams;
475
476 procedure Dispose is new
477 Ada.Unchecked_Deallocation (
478 Stream_Element_Array,
479 Stream_Element_Array_Access);
480
481 procedure Resize (A : in out Stream_Element_Array_Access;
482 A_Last_Used : Stream_Element_Offset;
483 New_Size : Stream_Element_Offset)
484 is
485 Hlp : constant Stream_Element_Array_Access :=
486 new Stream_Element_Array (1 .. New_Size);
487 begin
488 if A = null then
489 A := Hlp;
490 else
491 for I in 1 .. Stream_Element_Offset'Min (Hlp'Last, A_Last_Used) loop
492 Hlp (I) := A (I);
493 end loop;
494 Dispose (A);
495 A := Hlp;
496 end if;
497 end Resize;
498
499 overriding procedure Write
500 (Stream : in out Zip_Entry_Stream_Type;
501 Item : Ada.Streams.Stream_Element_Array)
502 is
503 Needed : Stream_Element_Offset;
504 begin
505 if Stream.Buffer_Access = null then
506 raise Ada.IO_Exceptions.Use_Error
507 with "Stream is not open (Zip_Entry_Stream_Type)";
508 end if;
509 Needed := Stream.Last_Element + Item'Length;
510 if Stream.Buffer_Access'Length < Needed then
511 declare
512 New_Size : Stream_Element_Offset := Stream.Buffer_Access'Length;
513 Growth : constant Stream_Element_Offset
514 := Stream_Element_Offset (Stream.Growth);
515 begin
516 loop
517 if New_Size > Stream_Element_Offset'Last / Growth then
518 -- We want to avoid an out-of-range with New_Size * Growth.
519 raise Constraint_Error
520 with "Buffer capacity exhaustion (Zip_Entry_Stream_Type)";
521 end if;
522 New_Size := New_Size * Growth;
523 exit when New_Size >= Needed;
524 end loop;
525 -- Ada.Text_IO.Put_Line("Grow");
526 Resize (Stream.Buffer_Access, Stream.Last_Element, New_Size);
527 end;
528 end if;
529 --
530 for I in Item'Range loop
531 Stream.Last_Element := Stream.Last_Element + 1;
532 Stream.Buffer_Access (Stream.Last_Element) := Item (I);
533 end loop;
534 end Write;
535
536 procedure Open (
537 Zip_Entry_Stream : out Zip_Entry_Stream_Type;
538 Initial_Buffer_Size : in Positive := Default_Zip_Entry_Buffer_Size;
539 Buffer_Growth_Factor : in Positive := Default_Zip_Entry_Buffer_Growth
540 )
541 is
542 begin
543 Zip_Entry_Stream.Last_Element := 0;
544 Zip_Entry_Stream.Growth := Buffer_Growth_Factor;
545 Resize (
546 Zip_Entry_Stream.Buffer_Access,
547 Zip_Entry_Stream.Last_Element,
548 Stream_Element_Offset (Initial_Buffer_Size)
549 );
550 end Open;
551
552 procedure Close (
553 Zip_Entry_Stream : in out Zip_Entry_Stream_Type;
554 Entry_Name : in String;
555 Creation_Time : in Zip.Time := default_creation_time;
556 Info : in out Zip_Create_Info
557 )
558 is
559 -- We define a local reader class for reading the contents of
560 -- Zip_Entry_Stream as an *input* stream.
561 type Captive_Type is new Zip_Streams.Root_Zipstream_Type with record
562 Loc : Stream_Element_Offset := 1;
563 end record;
564 --
565 overriding procedure Read
566 (Stream : in out Captive_Type;
567 Item : out Stream_Element_Array;
568 Last : out Stream_Element_Offset);
569 overriding procedure Write
570 (Stream : in out Captive_Type;
571 Item : Stream_Element_Array) is null;
572 overriding function Index (S : in Captive_Type) return Zip_Streams.ZS_Index_Type;
573 overriding function Size (S : in Captive_Type) return Zip_Streams.ZS_Size_Type;
574 overriding function End_Of_Stream (S : in Captive_Type) return Boolean;
575 --
576 overriding procedure Set_Index (
577 S : in out Captive_Type;
578 To : Zip_Streams.ZS_Index_Type)
579 is
580 begin
581 S.Loc := Stream_Element_Offset (To);
582 end Set_Index;
583 --
584 overriding function Index (S : in Captive_Type) return Zip_Streams.ZS_Index_Type is
585 begin
586 return Zip_Streams.ZS_Index_Type (S.Loc);
587 end Index;
588 --
589 overriding function Size (S : in Captive_Type) return Zip_Streams.ZS_Size_Type is
590 pragma Unreferenced (S);
591 begin
592 return Zip_Streams.ZS_Size_Type (Zip_Entry_Stream.Last_Element);
593 end Size;
594 --
595 overriding function End_Of_Stream (S : in Captive_Type) return Boolean is
596 begin
597 return S.Loc > Zip_Entry_Stream.Last_Element;
598 end End_Of_Stream;
599 --
600 overriding procedure Read
601 (Stream : in out Captive_Type;
602 Item : out Stream_Element_Array;
603 Last : out Stream_Element_Offset)
604 is
605 Available_From_Buffer : constant Stream_Element_Offset :=
606 Stream_Element_Offset'Max (
607 0,
608 1 + Zip_Entry_Stream.Last_Element - Stream.Loc
609 -- When Stream.Loc is equal to Zip_Entry_Stream.Last_Element,
610 -- there is one (last) element to read.
611 );
612 Copy_Length : constant Stream_Element_Offset :=
613 Stream_Element_Offset'Min (Item'Length, Available_From_Buffer);
614 begin
615 -- Read Copy_Length bytes from Zip_Entry_Stream.Buffer_Access,
616 -- position Stream.Loc, into Item.
617 -- Copy_Length = 0 when Item is empty or the buffer is
618 -- fully read (i.e., when Loc = Last_Element + 1).
619 Last := Item'First + Copy_Length - 1;
620 for Offset in reverse 0 .. Copy_Length - 1 loop
621 Item (Item'First + Offset) :=
622 Zip_Entry_Stream.Buffer_Access (Stream.Loc + Offset);
623 end loop;
624 Stream.Loc := Stream.Loc + Copy_Length;
625 end Read;
626 --
627 Reader_Stream : Captive_Type;
628 use type Zip_Streams.Time;
629 begin
630 Reader_Stream.Set_Name (Entry_Name);
631 if Creation_Time = use_clock
632 -- If we have use_file_modification_time by mistake, use clock as well:
633 or else Creation_Time = use_file_modification_time
634 then
635 Reader_Stream.Set_Time (Ada.Calendar.Clock);
636 else
637 Reader_Stream.Set_Time (Creation_Time);
638 end if;
639 --
640 Add_Stream (Info, Reader_Stream);
641 --
642 Dispose (Zip_Entry_Stream.Buffer_Access);
643 end Close;
644
645 procedure Finish (Info : in out Zip_Create_Info) is
646 ed : Zip.Headers.End_of_Central_Dir;
647 procedure Dispose is new Ada.Unchecked_Deallocation (String, p_String);
648 current_index : Zip_Streams.ZS_Index_Type;
649 --
650 -- If the stream is of File_Zipstream type or descendent, close the file too.
651 -- Deallocate catalogue entries.
652 procedure Close_eventual_file_and_deallocate is
653 begin
654 if Info.Stream.all in Zip_Streams.File_Zipstream'Class
655 and then Zip_Streams.File_Zipstream (Info.Stream.all).Is_Open
656 then
657 Zip_Streams.File_Zipstream (Info.Stream.all).Close;
658 end if;
659 if Info.Contains /= null then
660 for e in 1 .. Info.Last_entry loop
661 Dispose (Info.Contains (e).name);
662 end loop;
663 Dispose (Info.Contains);
664 end if;
665 Info.Last_entry := 0;
666 Info.name_dictionary.Clear;
667 end Close_eventual_file_and_deallocate;
668 --
669 needs_local_zip64 : Boolean;
670 fh_extra : Local_File_Header_Extension;
671 ed64l : Zip64_End_of_Central_Dir_Locator;
672 ed64 : Zip64_End_of_Central_Dir;
673 begin
674 --
675 -- 2/ Almost done - write Central Directory:
676 --
677 current_index := Info.Stream.Index;
678 ed.central_dir_offset := Unsigned_64 (current_index) - 1;
679 ed.total_entries := 0;
680 ed.central_dir_size := 0;
681 ed.main_comment_length := 0;
682 if Info.zip_archive_format = Zip_32
683 and then Info.Last_entry >= Integer_M32 (Unsigned_16'Last)
684 then
685 -- Promote format to Zip_64 (too many entries for Zip_32).
686 Info.zip_archive_format := Zip_64;
687 end if;
688 if Info.Contains /= null then
689 for cat of Info.Contains (1 .. Info.Last_entry) loop
690 ed.total_entries := ed.total_entries + 1;
691 needs_local_zip64 :=
692 Needs_Local_Zip_64_Header_Extension
693 (cat.head.short_info, cat.head.local_header_offset);
694 if needs_local_zip64 then
695 cat.head.short_info.extra_field_length := local_header_extension_length;
696 fh_extra.tag := 1;
697 fh_extra.size := local_header_extension_length - 4;
698 fh_extra.value_64 (1) := cat.head.short_info.dd.uncompressed_size;
699 fh_extra.value_64 (2) := cat.head.short_info.dd.compressed_size;
700 fh_extra.value_64 (3) := cat.head.local_header_offset;
701 cat.head.short_info.dd.uncompressed_size := 16#FFFF_FFFF#;
702 cat.head.short_info.dd.compressed_size := 16#FFFF_FFFF#;
703 cat.head.local_header_offset := 16#FFFF_FFFF#;
704 -- Promote format to Zip_64 (entry too large for Zip_32).
705 Info.zip_archive_format := Zip_64;
706 else
707 -- If there is no Zip_64 information,
708 -- we set the extra header in the central dirctory header as empty.
709 cat.head.short_info.extra_field_length := 0;
710 end if;
711 Write (Info.Stream.all, cat.head);
712 String'Write (Info.Stream, cat.name.all);
713 if needs_local_zip64 then
714 Write (Info.Stream.all, fh_extra, False);
715 end if;
716 ed.central_dir_size :=
717 ed.central_dir_size +
718 Headers.central_header_length +
719 Unsigned_64 (cat.head.short_info.filename_length) +
720 Unsigned_64 (cat.head.short_info.extra_field_length);
721 current_index := Info.Stream.Index;
722 end loop;
723 Check_Size (Info, current_index);
724 end if;
725 ed.disknum := 0;
726 ed.disknum_with_start := 0;
727 ed.disk_total_entries := ed.total_entries;
728 --
729 if Info.zip_archive_format = Zip_64 then
730 ed64l.number_of_the_disk_with_the_start_of_the_zip64_end_of_central_dir := 0;
731 ed64l.relative_offset_of_the_zip64_end_of_central_dir_record :=
732 Unsigned_64 (Info.Stream.Index - 1);
733 ed64l.total_number_of_disks := 1;
734 --
735 ed64.size := 44;
736 ed64.version_made_by := 16#2D#;
737 ed64.version_needed_to_extract := 16#2D#;
738 ed64.number_of_this_disk := ed.disknum;
739 ed64.number_of_the_disk_with_the_start_of_the_central_directory := ed.disknum_with_start;
740 ed64.total_number_of_entries_in_the_central_directory_on_this_disk := ed.disk_total_entries;
741 ed64.total_number_of_entries_in_the_central_directory := ed.total_entries;
742 ed64.size_of_the_central_directory := ed.central_dir_size;
743 ed64.offset_of_start_of_central_directory := ed.central_dir_offset;
744 Write (Info.Stream.all, ed64);
745 --
746 Write (Info.Stream.all, ed64l);
747 --
748 ed.disk_total_entries := 16#FFFF#;
749 ed.total_entries := 16#FFFF#;
750 ed.central_dir_size := 16#FFFF_FFFF#;
751 ed.central_dir_offset := 16#FFFF_FFFF#;
752 end if;
753 Write (Info.Stream.all, ed);
754 --
755 Close_eventual_file_and_deallocate;
756 end Finish;
757
758 end Zip.Create;
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.
