Source file : zip-create.adb
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;
with Ada.Text_IO;
with Interfaces; use Interfaces;
package body Zip.Create is
procedure Create(Info : out Zip_Create_info;
Z_Stream : in Zipstream_Class_Access;
Name : String;
Compress : Zip.Compress.Compression_Method:= Zip.Compress.Deflate_1;
Duplicates : Duplicate_name_policy:= admit_duplicates
)
is
begin
Info.Stream := Z_Stream;
Info.Compress := Compress;
if Name /= "" then
Set_Name (Info.Stream.all, Name);
end if;
--
-- If we have a real file (File_Zipstream or descendent), create the file too:
--
if Z_Stream.all in File_Zipstream'Class then
Zip_Streams.Create (File_Zipstream(Z_Stream.all), Zip_Streams.Out_File);
end if;
Info.Duplicates:= Duplicates;
end Create;
function Is_Created(Info: Zip_Create_info) return Boolean is
begin
return Info.Stream /= null;
end Is_Created;
procedure Set(Info : in out Zip_Create_info;
New_Method : Zip.Compress.Compression_Method)
is
begin
Info.Compress:= New_Method;
end Set;
function Name(Info: Zip_Create_info) return String is
begin
return Get_Name(Info.Stream.all);
end Name;
procedure Dispose is new
Ada.Unchecked_Deallocation (Dir_entries, Pdir_entries);
procedure Resize (A : in out Pdir_entries;
Size : Integer) is
Hlp : constant Pdir_entries := new Dir_entries (1 .. Size);
begin
if A = null then
A := Hlp;
else
Hlp (1 .. Integer'Min (Size, A'Length)) :=
A (1 .. Integer'Min (Size, A'Length));
Dispose (A);
A := Hlp;
end if;
end Resize;
-- Internal - add the catalogue entry corresponding to a
-- compressed file in the Zip archive.
-- The entire catalogue will be written at the end of the zip stream,
-- and the entry as a local header just before the compressed data.
-- The entry's is mostly incomplete in the end (name, size, ...); stream
-- operations on the archive being built are not performed here,
-- see Add_Stream for that.
--
procedure Add_catalogue_entry (Info: in out Zip_Create_info)
is
begin
if Info.Last_entry = 0 then
Info.Last_entry:= 1;
Resize (Info.Contains, 32);
else
Info.Last_entry:= Info.Last_entry + 1;
if Info.Last_entry > Info.Contains'Last then
-- Info.Contains is full, time to resize it!
-- We do nothing less than double the size - better than
-- whatever offer you'd get in your e-mails.
Resize (Info.Contains, Info.Contains'Last * 2);
end if;
end if;
declare
cfh: Central_File_Header renames Info.Contains(Info.Last_entry).head;
begin
-- Administration
cfh.made_by_version := 23; -- version 2.30
cfh.comment_length := 0;
cfh.disk_number_start := 0;
cfh.internal_attributes := 0; -- 0: binary; 1: text
cfh.external_attributes := 0;
cfh.short_info.needed_extract_version := 10; -- Value put by Zip/PKZip
cfh.short_info.bit_flag := 0;
end;
end Add_catalogue_entry;
-- This is just for detecting duplicates
procedure Insert_to_name_dictionary(file_name: String; node: in out p_Dir_node) is
begin
if node = null then
node:= new Dir_node'
( (name_len => file_name'Length,
left => null,
right => null,
file_name => file_name)
);
elsif file_name > node.file_name then
Insert_to_name_dictionary( file_name, node.right );
elsif file_name < node.file_name then
Insert_to_name_dictionary( file_name, node.left );
else
-- Name already registered
raise Duplicate_name;
end if;
end Insert_to_name_dictionary;
procedure Clear_name_dictionary(Info : in out Zip_Create_info) is
procedure Clear( p: in out p_Dir_node ) is
procedure Dispose is new Ada.Unchecked_Deallocation (Dir_node, p_Dir_node);
begin
if p /= null then
Clear(p.left);
Clear(p.right);
Dispose(p);
p:= null;
end if;
end Clear;
begin
Clear(Info.dir);
end Clear_name_dictionary;
procedure Add_Stream (Info : in out Zip_Create_info;
Stream : in out Root_Zipstream_Type'Class;
Password : in String:= "")
is
Compressed_Size: Zip.File_size_type; -- dummy
Final_Method : Natural; -- dummy
begin
Add_Stream(Info, Stream, null, Password, Compressed_Size, Final_Method);
end Add_Stream;
procedure Add_Stream (Info : in out Zip_Create_info;
Stream : in out Root_Zipstream_Type'Class;
Feedback : in Feedback_proc;
Password : in String:= "";
Compressed_Size: out Zip.File_size_type;
Final_Method : out Natural)
is
mem1, mem2 : ZS_Index_Type := 1;
entry_name : String:= Get_Name (Stream);
Last: Positive;
begin
-- Appnote.txt, V. J. :
-- " All slashes should be forward slashes '/' as opposed to backwards slashes '\' "
for i in entry_name'Range loop
if entry_name(i) = '\' then
entry_name(i):= '/';
end if;
end loop;
if Info.Duplicates = error_on_duplicate then
-- Check for duplicates; raises Duplicate_name in this case.
Insert_to_name_dictionary (entry_name, Info.dir);
end if;
Add_catalogue_entry (Info);
Last:= Info.Last_entry;
declare
cfh: Central_File_Header renames Info.Contains(Last).head;
shi: Local_File_Header renames cfh.short_info;
begin
-- Administration - continued
if Zip_Streams.Is_Unicode_Name (Stream) then
shi.bit_flag := shi.bit_flag or Zip.Headers.Language_Encoding_Flag_Bit;
end if;
if Password /= "" then
shi.bit_flag := shi.bit_flag or Zip.Headers.Encryption_Flag_Bit;
end if;
if Is_Read_Only(Stream) then
cfh.external_attributes:= cfh.external_attributes or 1;
end if;
shi.file_timedate := Get_Time (Stream);
shi.dd.uncompressed_size := Unsigned_32 (Size (Stream));
shi.filename_length := entry_name'Length;
Info.Contains (Last).name := new String'(entry_name);
shi.extra_field_length := 0;
mem1 := Index (Info.Stream.all);
cfh.local_header_offset := Unsigned_32 (mem1) - 1;
-- Write the local header with incomplete informations
Zip.Headers.Write (Info.Stream.all, shi);
String'Write(Info.Stream, entry_name);
-- Write compressed file
Zip.Compress.Compress_data
(input => Stream,
output => Info.Stream.all,
input_size_known => True,
input_size => shi.dd.uncompressed_size,
method => Info.Compress,
feedback => Feedback,
password => Password,
content_hint => Guess_type_from_name(entry_name),
CRC => shi.dd.crc_32,
output_size => shi.dd.compressed_size,
zip_type => shi.zip_type
);
if shi.zip_type = compression_format_code.lzma then
--
-- For LZMA, we always put an EOS marker. From PKWARE's Appnote:
--
-- 5.8.9 Data compressed with method 14, LZMA, may include an end-of-stream
-- (EOS) marker ending the compressed data stream. This marker is not
-- required, but its use is highly recommended to facilitate processing
-- and implementers should include the EOS marker whenever possible.
-- When the EOS marker is used, general purpose bit 1 must be set. If
-- general purpose bit 1 is not set, the EOS marker is not present.
--
shi.bit_flag := shi.bit_flag or LZMA_EOS_Flag_Bit;
end if;
mem2 := Index (Info.Stream.all);
-- Go back to the local header to rewrite it with complete informations
-- known after the compression: CRC value, compressed size, actual compression format.
Set_Index (Info.Stream.all, mem1);
Zip.Headers.Write (Info.Stream.all, shi);
-- Return to momentaneous end of file
Set_Index (Info.Stream.all, mem2);
--
Compressed_Size:= shi.dd.compressed_size;
Final_Method := Natural(shi.zip_type);
end;
end Add_Stream;
procedure Add_File (Info : in out Zip_Create_info;
Name : String;
Name_in_archive : String:= "";
-- default: add the file in the archive
-- under the same name
Delete_file_after : Boolean:= False;
-- practical to delete temporary file after adding
Name_encoding : Zip_name_encoding:= IBM_437;
Modification_time : Time:= default_time;
Is_read_only : Boolean:= False;
Feedback : Feedback_proc:= null;
Password : String:= ""
)
is
temp_zip_stream : aliased File_Zipstream;
use Ada.Text_IO;
fd: File_Type;
Compressed_Size: Zip.File_size_type; -- unused
Final_Method : Natural; -- unused
begin
-- Read the file
Set_Name(temp_zip_stream, Name);
Open(temp_zip_stream, Zip_Streams.In_File);
-- Eventually we set a new name for archiving:
if Name_in_archive /= "" then
Set_Name(temp_zip_stream, Name_in_archive);
end if;
Set_Unicode_Name_Flag(temp_zip_stream, Name_encoding = UTF_8);
Set_Read_Only_Flag(temp_zip_stream, Is_read_only);
Set_Time(temp_zip_stream, Modification_time);
-- Stuff into the .zip archive:
Add_Stream (Info, temp_zip_stream, Feedback, Password, Compressed_Size, Final_Method);
Close(temp_zip_stream);
if Delete_file_after then
Open(fd, In_File, Name);
Delete(fd);
end if;
exception
when User_abort =>
if Is_Open(temp_zip_stream) then
Close(temp_zip_stream);
end if;
raise;
end Add_File;
procedure Add_String (Info : in out Zip_Create_info;
Contents : String;
Name_in_archive : String;
-- Name_UTF_8_encoded = True if Name is actually UTF-8 encoded (Unicode)
Name_UTF_8_encoded: Boolean:= False;
Password : String:= "";
-- Time stamp for this entry, e.g. Zip.Convert(Ada.Calendar.Clock)
Creation_time : Zip.Time:= default_time
)
is
begin
Add_String(
Info => Info,
Contents => To_Unbounded_String(Contents),
Name_in_archive => Name_in_archive,
Name_UTF_8_encoded => Name_UTF_8_encoded,
Password => Password,
Creation_time => Creation_time
);
end Add_String;
procedure Add_String (Info : in out Zip_Create_info;
Contents : Unbounded_String;
Name_in_archive : String;
-- Name_UTF_8_encoded = True if Name is actually UTF-8 encoded (Unicode)
Name_UTF_8_encoded: Boolean:= False;
Password : String:= "";
-- Time stamp for this entry, e.g. Zip.Convert(Ada.Calendar.Clock)
Creation_time : Zip.Time:= default_time
)
is
temp_zip_stream : aliased Memory_Zipstream;
begin
Set(temp_zip_stream, Contents);
Set_Name(temp_zip_stream, Name_in_archive);
Set_Time(temp_zip_stream, Creation_time);
Set_Unicode_Name_Flag(temp_zip_stream, Name_UTF_8_encoded);
Add_Stream (Info, temp_zip_stream, Password);
end Add_String;
procedure Add_Compressed_Stream (
Info : in out Zip_Create_info;
Stream : in out Root_Zipstream_Type'Class;
Feedback : in Feedback_proc
)
is
lh: Zip.Headers.Local_File_Header;
begin
Zip.Headers.Read_and_check(Stream, lh);
-- Copy name and ignore extra field
declare
name: String(1..Positive(lh.filename_length));
extra: String(1..Natural(lh.extra_field_length));
begin
String'Read(Stream'Access, name);
String'Read(Stream'Access, extra);
if Info.Duplicates = error_on_duplicate then
-- Check for duplicates; raises Duplicate_name in this case:
Insert_to_name_dictionary (name, Info.dir);
end if;
Add_catalogue_entry (Info);
Info.Contains (Info.Last_entry).head.local_header_offset :=
Unsigned_32 (Index (Info.Stream.all)) - 1;
Info.Contains (Info.Last_entry).name := new String'(name);
lh.extra_field_length:= 0; -- extra field is zeroed (causes problems if not)
Zip.Headers.Write(Info.Stream.all, lh); -- Copy local header to new stream
String'Write(Info.Stream, name); -- Copy entry name to new stream
end;
Zip.Copy_chunk(
Stream,
Info.Stream.all,
Integer(lh.dd.compressed_size),
Feedback => Feedback
);
Info.Contains (Info.Last_entry).head.short_info:= lh;
end Add_Compressed_Stream;
procedure Finish (Info : in out Zip_Create_info) is
ed : Zip.Headers.End_of_Central_Dir;
procedure Dispose is new Ada.Unchecked_Deallocation (String, p_String);
begin
--
-- 2/ Almost done - write Central Directory:
--
ed.central_dir_offset := Unsigned_32 (Index (Info.Stream.all)) - 1;
ed.total_entries := 0;
ed.central_dir_size := 0;
ed.main_comment_length := 0;
if Info.Last_entry > Integer(Unsigned_16'Last) then
Ada.Exceptions.Raise_Exception
(Constraint_Error'Identity, "Too many entries - need ZIP64");
end if;
if Info.Contains /= null then
for e in 1..Info.Last_entry loop
ed.total_entries := ed.total_entries + 1;
Zip.Headers.Write (Info.Stream.all, Info.Contains (e).head);
String'Write(Info.Stream, Info.Contains (e).name.all);
-- The extra field here is assumed to be empty!
ed.central_dir_size :=
ed.central_dir_size +
Zip.Headers.central_header_length +
Unsigned_32 (Info.Contains (e).head.short_info.filename_length);
Dispose(Info.Contains(e).name);
end loop;
Dispose (Info.Contains);
end if;
Info.Last_entry:= 0;
Clear_name_dictionary (Info);
ed.disknum := 0;
ed.disknum_with_start := 0;
ed.disk_total_entries := ed.total_entries;
Zip.Headers.Write (Info.Stream.all, ed);
--
-- If we have a real file (File_Zipstream or descendent), close the file too:
--
if Info.Stream.all in File_Zipstream'Class then
Zip_Streams.Close (File_Zipstream(Info.Stream.all));
end if;
end Finish;
end Zip.Create;
Zip-Ada: Ada library for zip archive files (.zip).
Ada programming.
Some news about Zip-Ada and other related Ada projects
on Gautier's blog.
