Source file : unzip-streams.adb
1 -- Legal licensing note:
2
3 -- Copyright (c) 1999 .. 2024 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 on the site
25 -- http://www.opensource.org/licenses/mit-license.php
26
27 with Zip.Headers, UnZip.Decompress;
28
29 with Ada.Strings.Unbounded,
30 Ada.Unchecked_Deallocation;
31
32 with Interfaces;
33
34 package body UnZip.Streams is
35
36 procedure Dispose is new
37 Ada.Unchecked_Deallocation (String, p_String);
38
39 procedure Dispose is new
40 Ada.Unchecked_Deallocation (Ada.Streams.Stream_Element_Array,
41 p_Stream_Element_Array);
42
43 procedure Dispose is new
44 Ada.Unchecked_Deallocation (UnZip_Stream_Type,
45 Zipped_File_Type);
46
47 use Interfaces;
48
49 --------------------------------------------------
50 -- *The* internal 1-file unzipping procedure. --
51 -- Input must be _open_ and won't be _closed_ ! --
52 --------------------------------------------------
53
54 procedure UnZipFile (
55 zip_stream : in out Zip_Streams.Root_Zipstream_Type'Class;
56 header_index : in out Zip_Streams.ZS_Index_Type;
57 mem_ptr : out p_Stream_Element_Array;
58 out_stream_ptr : p_Stream;
59 -- if not null, extract to out_stream_ptr, not to memory
60 password : in out Ada.Strings.Unbounded.Unbounded_String;
61 hint_comp_size : in Zip.Zip_64_Data_Size_Type; -- Added 2007 for .ODS files
62 hint_crc_32 : in Unsigned_32; -- Added 2012 for decryption
63 cat_uncomp_size : in Zip.Zip_64_Data_Size_Type
64 )
65 is
66 work_index : Zip_Streams.ZS_Index_Type := header_index;
67 local_header : Zip.Headers.Local_File_Header;
68 data_descriptor_after_data : Boolean;
69 encrypted : Boolean;
70 method : Zip.PKZip_method;
71 use type Zip.PKZip_method;
72 mode : Write_Mode_Type;
73 begin
74 begin
75 Zip_Streams.Set_Index (zip_stream, header_index);
76 Zip.Headers.Read_and_Check (zip_stream, local_header);
77 exception
78 when Zip.Headers.bad_local_header =>
79 raise Zip.Archive_corrupted with "Bad local header";
80 when others =>
81 raise Zip.Archive_corrupted;
82 end;
83
84 method := Zip.Method_from_Code (local_header.zip_type);
85 if method = Zip.unknown then
86 raise Unsupported_method;
87 end if;
88
89 -- Calculate offset of data
90
91 work_index :=
92 work_index +
93 Zip_Streams.ZS_Size_Type
94 (local_header.filename_length +
95 local_header.extra_field_length +
96 Zip.Headers.local_header_length);
97
98 --
99 -- Zip64 extension.
100 --
101 if local_header.extra_field_length >= 4 then
102 declare
103 mem : constant Zip_Streams.ZS_Index_Type := Zip_Streams.Index (zip_stream);
104 local_header_extension : Zip.Headers.Local_File_Header_Extension;
105 dummy_offset : Unsigned_64 := 0;
106 -- ^ Initialized for avoiding a random value being by mistake 16#FFFF_FFFF#
107 begin
108 Zip_Streams.Set_Index (zip_stream, mem + Zip_Streams.ZS_Index_Type (local_header.filename_length));
109 Zip.Headers.Read_and_Check (zip_stream, local_header_extension);
110 Zip_Streams.Set_Index (zip_stream, mem);
111 Zip.Headers.Interpret
112 (local_header_extension,
113 local_header.dd.uncompressed_size,
114 local_header.dd.compressed_size,
115 dummy_offset);
116 end;
117 end if;
118
119 data_descriptor_after_data := (local_header.bit_flag and 8) /= 0;
120
121 if data_descriptor_after_data then
122 -- Sizes and crc are after the data
123 local_header.dd.crc_32 := hint_crc_32;
124 local_header.dd.uncompressed_size := cat_uncomp_size;
125 local_header.dd.compressed_size := hint_comp_size;
126 else
127 -- Sizes and crc are before the data
128 if cat_uncomp_size /= local_header.dd.uncompressed_size then
129 raise Uncompressed_Size_Error
130 with "Uncompressed size mismatch: in catalogue:" & cat_uncomp_size'Image &
131 "; in local header:" & local_header.dd.uncompressed_size'Image;
132 end if;
133 end if;
134
135 encrypted := (local_header.bit_flag and Zip.Headers.Encryption_Flag_Bit) /= 0;
136
137 begin
138 Zip_Streams.Set_Index (zip_stream, work_index); -- eventually skips the file name
139 exception
140 when others =>
141 raise Zip.Archive_corrupted with
142 "End of stream reached (location: between local header and archived data)";
143 end;
144
145 if out_stream_ptr = null then
146 mode := write_to_memory;
147 else
148 mode := write_to_stream;
149 end if;
150 -- Unzip correct type
151 UnZip.Decompress.Decompress_Data (
152 zip_file => zip_stream,
153 format => method,
154 write_mode => mode,
155 output_file_name => "",
156 output_memory_access => mem_ptr,
157 output_stream_access => out_stream_ptr,
158 feedback => null,
159 explode_literal_tree => (local_header.bit_flag and 4) /= 0,
160 explode_slide_8KB_LZMA_EOS => (local_header.bit_flag and Zip.Headers.LZMA_EOS_Flag_Bit) /= 0,
161 data_descriptor_after_data => data_descriptor_after_data,
162 is_encrypted => encrypted,
163 password => password,
164 get_new_password => null,
165 hint => local_header
166 );
167
168 -- Set the offset on the next zipped file
169 header_index := header_index +
170 Zip_Streams.ZS_Size_Type (
171 local_header.filename_length +
172 local_header.extra_field_length +
173 Zip.Headers.local_header_length
174 ) +
175 Zip_Streams.ZS_Size_Type (
176 local_header.dd.compressed_size
177 );
178
179 if data_descriptor_after_data then
180 header_index := header_index +
181 Zip_Streams.ZS_Size_Type (Zip.Headers.data_descriptor_length);
182 end if;
183
184 end UnZipFile;
185
186 procedure S_Extract
187 (from : in Zip.Zip_Info;
188 zip_stream : in out Zip_Streams.Root_Zipstream_Type'Class;
189 what : in String;
190 password : in String;
191 mem_ptr : out p_Stream_Element_Array;
192 out_stream_ptr : in p_Stream;
193 Ignore_Directory : in Boolean)
194 is
195 header_index : Zip_Streams.ZS_Index_Type;
196 comp_size : Zip.Zip_64_Data_Size_Type;
197 uncomp_size : Zip.Zip_64_Data_Size_Type;
198 crc_32 : Interfaces.Unsigned_32;
199 work_password : Ada.Strings.Unbounded.Unbounded_String :=
200 Ada.Strings.Unbounded.To_Unbounded_String (password);
201 dummy_name_encoding : Zip.Zip_Name_Encoding;
202
203 begin
204 if Ignore_Directory then
205 Zip.Find_Offset_without_Directory
206 (info => from,
207 name => what,
208 name_encoding => dummy_name_encoding,
209 file_index => header_index,
210 comp_size => comp_size,
211 uncomp_size => uncomp_size,
212 crc_32 => crc_32);
213 else
214 Zip.Find_Offset
215 (info => from,
216 name => what,
217 name_encoding => dummy_name_encoding,
218 file_index => header_index,
219 comp_size => comp_size,
220 uncomp_size => uncomp_size,
221 crc_32 => crc_32);
222 end if;
223 UnZipFile
224 (zip_stream => zip_stream,
225 header_index => header_index,
226 mem_ptr => mem_ptr,
227 out_stream_ptr => out_stream_ptr,
228 password => work_password,
229 hint_comp_size => comp_size,
230 hint_crc_32 => crc_32,
231 cat_uncomp_size => uncomp_size);
232 end S_Extract;
233
234 -------------------- for exportation:
235
236 procedure Close (File : in out Zipped_File_Type) is
237 begin
238 if File = null or else File.state = uninitialized then
239 raise Use_Error;
240 end if;
241 Dispose (File.file_name);
242 Dispose (File.uncompressed);
243 Dispose (File);
244 File := null;
245 end Close;
246
247 function Name (File : in Zipped_File_Type) return String is
248 begin
249 return File.file_name.all;
250 end Name;
251
252 function Is_Open (File : in Zipped_File_Type) return Boolean is
253 begin
254 return File /= null and then File.state /= uninitialized;
255 end Is_Open;
256
257 function End_Of_File (File : in Zipped_File_Type) return Boolean is
258 begin
259 if File = null or else File.state = uninitialized then
260 raise Use_Error;
261 end if;
262 return File.state = end_of_zip;
263 end End_Of_File;
264
265 procedure Open
266 (File : in out Zipped_File_Type; -- File-in-archive handle
267 Archive_Info : in Zip.Zip_Info; -- Archive's Zip_info
268 Name : in String; -- Name of zipped entry
269 Password : in String := ""; -- Decryption password
270 Ignore_Directory : in Boolean := False) -- True: will open Name in first directory found
271 is
272 use Zip_Streams, Ada.Streams;
273 zip_stream : aliased File_Zipstream;
274 input_stream : Zipstream_Class_Access;
275 use_a_file : constant Boolean := Zip.Zip_Stream (Archive_Info) = null;
276 begin
277 if File = null then
278 File := new UnZip_Stream_Type;
279 elsif File.state /= uninitialized then -- forgot to close last time!
280 raise Use_Error;
281 end if;
282 if use_a_file then
283 input_stream := zip_stream'Unchecked_Access;
284 Set_Name (zip_stream, Zip.Zip_Name (Archive_Info));
285 Open (zip_stream, In_File);
286 else -- use the given stream
287 input_stream := Zip.Zip_Stream (Archive_Info);
288 end if;
289 --
290 File.archive_info := Archive_Info; -- Full clone. Now a copy is safely with File.
291 File.file_name := new String'(Name);
292 begin
293 S_Extract (
294 File.archive_info,
295 input_stream.all,
296 Name,
297 Password,
298 File.uncompressed,
299 null,
300 Ignore_Directory
301 );
302 if use_a_file then
303 Close (zip_stream);
304 end if;
305 exception
306 when others =>
307 if use_a_file then
308 Close (zip_stream);
309 end if;
310 raise;
311 end;
312 File.index := File.uncompressed'First;
313 File.state := data_uncompressed;
314 -- Bug fix for data of size 0 - 29-Nov-2002
315 if File.uncompressed'Last < File.index then -- (1..0) array
316 File.state := end_of_zip;
317 end if;
318 end Open;
319
320 procedure Open
321 (File : in out Zipped_File_Type; -- File-in-archive handle
322 Archive_Name : in String; -- Name of archive file
323 Name : in String; -- Name of zipped entry
324 Password : in String := ""; -- Decryption password
325 Case_sensitive : in Boolean := False;
326 Ignore_Directory : in Boolean := False) -- True: will open Name in first directory found
327 is
328 temp_info : Zip.Zip_Info;
329 begin
330 Zip.Load (temp_info, Archive_Name, Case_sensitive);
331 Open (File, temp_info, Name, Password, Ignore_Directory);
332 end Open;
333
334 procedure Open
335 (File : in out Zipped_File_Type; -- File-in-archive handle
336 Archive_Stream : in out Zip_Streams.Root_Zipstream_Type'Class; -- Archive's stream
337 Name : in String; -- Name of zipped entry
338 Password : in String := ""; -- Decryption password
339 Case_sensitive : in Boolean := False;
340 Ignore_Directory : in Boolean := False) -- True: will open Name in first directory found
341 is
342 temp_info : Zip.Zip_Info;
343 begin
344 Zip.Load (temp_info, Archive_Stream, Case_sensitive);
345 Open (File, temp_info, Name, Password, Ignore_Directory);
346 end Open;
347
348 ------------------------------------------
349 -- Read procedure for Unzip_Stream_Type --
350 ------------------------------------------
351
352 overriding procedure Read
353 (Self : in out UnZip_Stream_Type;
354 Item : out Ada.Streams.Stream_Element_Array;
355 Last : out Ada.Streams.Stream_Element_Offset)
356 is
357 use Ada.Streams;
358 begin
359 if Self.state = uninitialized then
360 raise Use_Error;
361 end if;
362 if Self.state = end_of_zip then
363 -- Zero transfer -> Last:= Item'First - 1, see RM 13.13.1(8)
364 -- No End_Error here, T'Read will raise it: RM 13.13.2(37)
365 if Item'First > Stream_Element_Offset'First then
366 Last := Item'First - 1;
367 return;
368 else
369 -- Well, we cannot return Item'First - 1...
370 raise Constraint_Error; -- RM 13.13.1(11) requires this.
371 end if;
372 end if;
373 if Item'Length = 0 then
374 -- Nothing to be read actually.
375 Last := Item'Last; -- this is < Item'First
376 return;
377 end if;
378 -- From now on, we can assume Item'Length > 0.
379
380 if Self.index + Item'Length <= Self.uncompressed'Last then
381 -- * Normal case: even after reading, the index will be in the range
382 Last := Item'Last;
383 Item :=
384 Self.uncompressed (Self.index .. Self.index + Item'Length - 1);
385 Self.index := Self.index + Item'Length;
386 -- Now: Stream.index <= Stream.uncompressed'Last,
387 -- then at least one element is left to be read, end_of_zip not possible
388 else
389 -- * Special case: we exhaust the buffer
390 Last := Item'First + (Self.uncompressed'Last - Self.index);
391 Item (Item'First .. Last) :=
392 Self.uncompressed (Self.index .. Self.uncompressed'Last);
393 Self.state := end_of_zip;
394 -- If Last < Item'Last, the T'Read attribute raises End_Error
395 -- because of the incomplete reading.
396 end if;
397 end Read;
398
399 function Stream (File : Zipped_File_Type) return Stream_Access is
400 begin
401 return Stream_Access (File);
402 end Stream;
403
404 procedure Set_Index (File : in Zipped_File_Type; To : in Positive_Count) is
405 use Ada.Streams;
406 begin
407 -- In the RM, A.12.1 The Package Streams.Stream_IO, 1.1/1,
408 -- the behaviour of the current index is said to be described in A.8.
409 --
410 -- In A.8.5, Set_Index's behaviour beyond the size is specified as such:
411 -- "Sets the current index of the given file to the given index
412 -- value (which may exceed the current size of the file)."
413 --
414 -- Empirical verification: GNAT doesn't set a limit to the index.
415 -- Only when a read occurs off the actual file limits, an End_Error is
416 -- raised.
417 File.index :=
418 Stream_Element_Offset (To - 1) + File.uncompressed'First;
419 end Set_Index;
420
421 function Index (File : in Zipped_File_Type) return Positive_Count is
422 use Ada.Streams;
423 begin
424 return Positive_Count (File.index - File.uncompressed'First) + 1;
425 end Index;
426
427 function Size (File : in Zipped_File_Type) return Count is
428 comp_size : Zip.Zip_64_Data_Size_Type;
429 uncomp_size : Zip.Zip_64_Data_Size_Type;
430 begin
431 Zip.Get_Sizes (File.archive_info, File.file_name.all, comp_size, uncomp_size);
432 return Count (uncomp_size);
433 end Size;
434
435 overriding procedure Write
436 (Self : in out UnZip_Stream_Type;
437 Item : in Ada.Streams.Stream_Element_Array)
438 is
439 write_not_supported : exception;
440 begin
441 raise write_not_supported;
442 end Write;
443
444 procedure Extract
445 (Destination : in out Ada.Streams.Root_Stream_Type'Class;
446 Archive_Info : in Zip.Zip_Info; -- Archive's Zip_info
447 Entry_Name : in String; -- Name of zipped entry
448 Password : in String := ""; -- Decryption password
449 Ignore_Directory : in Boolean := False) -- True: will open Name in first directory found
450 is
451 use Zip_Streams;
452 zip_stream : aliased File_Zipstream;
453 input_stream : Zipstream_Class_Access;
454 use_a_file : constant Boolean := Zip.Zip_Stream (Archive_Info) = null;
455 begin
456 if use_a_file then
457 input_stream := zip_stream'Unchecked_Access;
458 Set_Name (zip_stream, Zip.Zip_Name (Archive_Info));
459 Open (zip_stream, In_File);
460 else -- use the given stream
461 input_stream := Zip.Zip_Stream (Archive_Info);
462 end if;
463 declare
464 dummy_mem_ptr : p_Stream_Element_Array;
465 begin
466 S_Extract (
467 Archive_Info,
468 input_stream.all,
469 Entry_Name,
470 Password,
471 dummy_mem_ptr,
472 Destination'Unchecked_Access,
473 Ignore_Directory
474 );
475 if use_a_file then
476 Close (zip_stream);
477 end if;
478 exception
479 when others =>
480 if use_a_file then
481 Close (zip_stream);
482 end if;
483 raise;
484 end;
485 end Extract;
486
487 end UnZip.Streams;
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.
