Source file : zip.adb
with Zip.Headers;
with Ada.Characters.Handling;
with Ada.Unchecked_Deallocation;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.IO_Exceptions;
with Ada.Strings.Fixed;
with Ada.Strings.Unbounded;
package body Zip is
use Interfaces;
procedure Dispose is new Ada.Unchecked_Deallocation( Dir_node, p_Dir_node );
procedure Dispose is new Ada.Unchecked_Deallocation( String, p_String );
package Binary_tree_rebalancing is
procedure Rebalance( root: in out p_Dir_node );
end Binary_tree_rebalancing;
package body Binary_tree_rebalancing is
-------------------------------------------------------------------
-- Tree Rebalancing in Optimal Time and Space --
-- QUENTIN F. STOUT and BETTE L. WARREN --
-- Communications of the ACM September 1986 Volume 29 Number 9 --
-------------------------------------------------------------------
-- http://www.eecs.umich.edu/~qstout/pap/CACM86.pdf
--
-- Translated by (New) P2Ada v. 15-Nov-2006
procedure Tree_to_vine( root: p_Dir_node; size: out Integer )
-- transform the tree with pseudo-root
-- "root^" into a vine with pseudo-root
-- node "root^", and store the number of
-- nodes in "size"
is
vine_tail, remainder, temp: p_Dir_node;
begin
vine_tail := root;
remainder := vine_tail.right;
size := 0;
while remainder /= null loop
if remainder.left = null then
-- move vine-tail down one:
vine_tail := remainder;
remainder := remainder.right;
size := size + 1;
else
-- rotate:
temp := remainder.left;
remainder.left := temp.right;
temp.right := remainder;
remainder := temp;
vine_tail.right := temp;
end if;
end loop;
end Tree_to_vine;
procedure Vine_to_tree( root: p_Dir_node; size_given: Integer ) is
-- convert the vine with "size" nodes and pseudo-root
-- node "root^" into a balanced tree
leaf_count: Integer;
size : Integer:= size_given;
procedure Compression( root: p_Dir_node; count: Integer ) is
-- compress "count" spine nodes in the tree with pseudo-root "root^"
scanner, child: p_Dir_node;
begin
scanner := root;
for i in 1..count loop
child := scanner.right;
scanner.right := child.right;
scanner := scanner.right;
child.right := scanner.left;
scanner.left := child;
end loop;
end Compression;
-- Returns n - 2 ** Integer( Float'Floor( log( Float(n) ) / log(2.0) ) )
-- without Float-Point calculation and rounding errors with too short floats
function Remove_leading_binary_1( n: Integer ) return Integer is
x: Integer:= 2**16; -- supposed maximum
begin
if n < 1 then
return n;
end if;
while n mod x = n loop
x:= x / 2;
end loop;
return n mod x;
end Remove_leading_binary_1;
begin -- Vine_to_tree
leaf_count := Remove_leading_binary_1(size + 1);
Compression(root, leaf_count); -- create deepest leaves
-- use Perfect_leaves instead for a perfectly balanced tree
size := size - leaf_count;
while size > 1 loop
Compression(root, size / 2);
size := size / 2;
end loop;
end Vine_to_tree;
procedure Rebalance( root: in out p_Dir_node ) is
-- Rebalance the binary search tree with root "root.all",
-- with the result also rooted at "root.all".
-- Uses the Tree_to_vine and Vine_to_tree procedures.
pseudo_root: p_Dir_node;
size: Integer;
begin
pseudo_root:= new Dir_node(name_len => 0);
pseudo_root.right := root;
Tree_to_vine(pseudo_root, size);
Vine_to_tree(pseudo_root, size);
root := pseudo_root.right;
Dispose(pseudo_root);
end Rebalance;
end Binary_tree_rebalancing;
-- 19-Jun-2001: Enhanced file name identification
-- a) when case insensitive -> all UPPER (current)
-- b) '\' and '/' identified -> all '/' (new)
function Normalize( s: String; case_sensitive: Boolean ) return String is
sn: String( s'Range );
begin
if case_sensitive then
sn:= s;
else
sn:= Ada.Characters.Handling.To_Upper(s);
end if;
for i in sn'Range loop
if sn(i)= '\' then
sn(i):='/';
end if;
end loop;
return sn;
end Normalize;
boolean_to_encoding: constant array(Boolean) of Zip_name_encoding:=
(False => IBM_437, True => UTF_8);
-------------------------------------------------------------
-- Load Zip_info from a stream containing the .zip archive --
-------------------------------------------------------------
procedure Load(
info : out Zip_info;
from : in out Zip_Streams.Root_Zipstream_Type'Class;
case_sensitive : in Boolean:= False;
duplicate_names : in Duplicate_name_policy:= error_on_duplicate
)
is
use type Zip_Streams.ZS_Size_Type;
procedure Insert(
dico_name : String; -- UPPER if case-insensitive search
file_name : String;
file_index : Zip_Streams.ZS_Index_Type;
comp_size,
uncomp_size : File_size_type;
crc_32 : Unsigned_32;
date_time : Time;
method : PKZip_method;
name_encoding : Zip_name_encoding;
read_only : Boolean;
encrypted_2_x : Boolean;
root_node : in out p_Dir_node
)
is
procedure Insert_into_tree(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,
dico_name => dico_name,
file_name => file_name,
file_index => file_index,
comp_size => comp_size,
uncomp_size => uncomp_size,
crc_32 => crc_32,
date_time => date_time,
method => method,
name_encoding => name_encoding,
read_only => read_only,
encrypted_2_x => encrypted_2_x,
user_code => 0
)
);
elsif dico_name > node.dico_name then
Insert_into_tree(node.right);
elsif dico_name < node.dico_name then
Insert_into_tree(node.left);
else
-- Here we have a case where the entry name already exists in the dictionary.
case duplicate_names is
when error_on_duplicate =>
Ada.Exceptions.Raise_Exception
(Duplicate_name'Identity,
"Same full entry name (in dictionary: " & dico_name &
") appears twice in archive directory; " &
"procedure Load was called with strict name policy."
);
when admit_duplicates =>
if file_index > node.file_index then
Insert_into_tree(node.right);
elsif file_index < node.file_index then
Insert_into_tree(node.left);
else
Ada.Exceptions.Raise_Exception
(Duplicate_name'Identity,
"Archive directory corrupt: same full entry name (in dictionary: " &
dico_name & "), with same data position, appear twice."
);
end if;
end case;
end if;
end Insert_into_tree;
--
begin
Insert_into_tree(root_node);
end Insert;
the_end: Zip.Headers.End_of_Central_Dir;
header : Zip.Headers.Central_File_Header;
p : p_Dir_node:= null;
zip_info_already_loaded: exception;
main_comment: p_String;
begin -- Load Zip_info
if info.loaded then
raise zip_info_already_loaded;
end if; -- 15-Apr-2002
Zip.Headers.Load(from, the_end);
-- We take the opportunity to read the main comment, which is right
-- after the end-of-central-directory block.
main_comment:= new String(1..Integer(the_end.main_comment_length));
String'Read(from'Access, main_comment.all);
-- Process central directory:
Zip_Streams.Set_Index(
from,
Zip_Streams.ZS_Index_Type(1 + the_end.central_dir_offset) + the_end.offset_shifting
);
for i in 1..the_end.total_entries loop
Zip.Headers.Read_and_check(from, header );
declare
this_name: String(1..Natural(header.short_info.filename_length));
use Zip_Streams;
begin
String'Read(from'Access, this_name);
-- Skip extra field and entry comment.
Set_Index(
from,
Index( from ) +
ZS_Size_Type (
header.short_info.extra_field_length +
header.comment_length
)
);
-- Now the whole i_th central directory entry is behind
Insert( dico_name => Normalize(this_name, case_sensitive),
file_name => Normalize(this_name, True),
file_index => Zip_Streams.ZS_Index_Type (1 + header.local_header_offset) +
the_end.offset_shifting,
comp_size => header.short_info.dd.compressed_size,
uncomp_size => header.short_info.dd.uncompressed_size,
crc_32 => header.short_info.dd.crc_32,
date_time => header.short_info.file_timedate,
method => Method_from_code(header.short_info.zip_type),
name_encoding =>
boolean_to_encoding(
(header.short_info.bit_flag and
Zip.Headers.Language_Encoding_Flag_Bit) /= 0),
read_only => header.made_by_version / 256 = 0 and -- DOS-like
(header.external_attributes and 1) = 1,
encrypted_2_x => (header.short_info.bit_flag and Zip.Headers.Encryption_Flag_Bit) /= 0,
root_node => p );
-- Since the files are usually well ordered, the tree as inserted
-- is very unbalanced; we need to rebalance it from time to time
-- during loading, otherwise the insertion slows down dramatically
-- for zip files with plenty of files - converges to
-- O(total_entries ** 2)...
if i mod 256 = 0 then
Binary_tree_rebalancing.Rebalance(p);
end if;
end;
end loop;
Binary_tree_rebalancing.Rebalance(p);
info:= ( loaded => True,
case_sensitive => case_sensitive,
zip_file_name => new String'("This is a stream, no direct file!"),
zip_input_stream => from'Unchecked_Access,
dir_binary_tree => p,
total_entries => Integer(the_end.total_entries),
zip_file_comment => main_comment
);
exception
when Zip.Headers.bad_end =>
Raise_Exception (Zip.Archive_corrupted'Identity, "Bad (or no) end-of-central-directory");
when Zip.Headers.bad_central_header =>
Raise_Exception (Zip.Archive_corrupted'Identity, "Bad central directory entry header");
end Load;
-----------------------------------------------------------
-- Load Zip_info from a file containing the .zip archive --
-----------------------------------------------------------
procedure Load(
info : out Zip_info;
from : in String; -- Zip file name
case_sensitive : in Boolean:= False;
duplicate_names : in Duplicate_name_policy:= error_on_duplicate
)
is
use Zip_Streams;
MyStream : aliased File_Zipstream;
begin
Set_Name (MyStream, from);
begin
Open (MyStream, In_File);
exception
when others =>
Raise_Exception (Zip_file_open_error'Identity, "Archive: [" & from & ']');
end;
-- Call the stream version of Load(...)
Load(
info,
MyStream,
case_sensitive,
duplicate_names
);
Close (MyStream);
Dispose(info.zip_file_name);
info.zip_file_name:= new String'(from);
info.zip_input_stream:= null; -- forget about the stream!
exception
when others =>
if Is_Open(MyStream) then
Close(MyStream);
end if;
raise;
end Load;
function Is_loaded (info: in Zip_info) return Boolean is
begin
return info.loaded;
end Is_loaded;
function Zip_name( info: in Zip_info ) return String is
begin
if not info.loaded then
raise Forgot_to_load_zip_info;
end if;
return info.zip_file_name.all;
end Zip_name;
function Zip_comment( info: in Zip_info ) return String is
begin
if not info.loaded then
raise Forgot_to_load_zip_info;
end if;
return info.zip_file_comment.all;
end Zip_comment;
function Zip_stream( info: in Zip_info ) return Zip_Streams.Zipstream_Class_Access
is
begin
if not info.loaded then
raise Forgot_to_load_zip_info;
end if;
return info.zip_input_stream;
end Zip_stream;
function Entries( info: in Zip_info ) return Natural is
begin
return info.total_entries;
end Entries;
------------
-- Delete --
------------
procedure Delete (info : in out Zip_info) is
procedure Delete( p: in out p_Dir_node ) is
begin
if p/=null then
Delete(p.left);
Delete(p.right);
Dispose(p);
p:= null;
end if;
end Delete;
begin
if not info.loaded then
raise Forgot_to_load_zip_info;
end if;
Delete( info.dir_binary_tree );
Dispose( info.zip_file_name );
info.loaded:= False; -- <-- added 14-Jan-2002
end Delete;
-- Traverse a whole Zip_info directory in sorted order, giving the
-- name for each entry to an user-defined "Action" procedure.
generic
with procedure Action_private( dn: in out Dir_node );
-- Dir_node is private: only known to us, contents subject to change
procedure Traverse_private( z: Zip_info );
procedure Traverse_private( z: Zip_info ) is
procedure Traverse( p: p_Dir_node ) is
begin
if p /= null then
Traverse(p.left);
Action_private(p.all);
Traverse(p.right);
end if;
end Traverse;
begin
Traverse(z.dir_binary_tree);
end Traverse_private;
-----------------------
-- Public versions --
-----------------------
procedure Traverse( z: Zip_info ) is
procedure My_Action_private( dn: in out Dir_node ) is
pragma Inline(My_Action_private);
begin
Action(dn.file_name);
end My_Action_private;
procedure My_Traverse_private is new Traverse_private(My_Action_private);
begin
My_Traverse_private(z);
end Traverse;
procedure Traverse_Unicode( z: Zip_info ) is
procedure My_Action_private( dn: in out Dir_node ) is
pragma Inline(My_Action_private);
begin
Action(dn.file_name, dn.name_encoding);
end My_Action_private;
procedure My_Traverse_private is new Traverse_private(My_Action_private);
begin
My_Traverse_private(z);
end Traverse_Unicode;
procedure Traverse_verbose( z: Zip_info ) is
procedure My_Action_private( dn: in out Dir_node ) is
pragma Inline(My_Action_private);
begin
Action(
dn.file_name,
dn.file_index,
dn.comp_size,
dn.uncomp_size,
dn.crc_32,
dn.date_time,
dn.method,
dn.name_encoding,
dn.read_only,
dn.encrypted_2_x,
dn.user_code
);
end My_Action_private;
procedure My_Traverse_private is new Traverse_private(My_Action_private);
begin
My_Traverse_private(z);
end Traverse_verbose;
procedure Tree_stat(
z : in Zip_info;
total : out Natural;
max_depth: out Natural;
avg_depth: out Float
)
is
sum_depth: Natural:= 0;
procedure Traverse( p: p_Dir_node; depth: Natural ) is
begin
if p /= null then
total:= total + 1;
if depth > max_depth then
max_depth:= depth;
end if;
sum_depth:= sum_depth + depth;
Traverse(p.left, depth + 1);
Traverse(p.right, depth + 1);
end if;
end Traverse;
begin
total:= 0;
max_depth:= 0;
Traverse(z.dir_binary_tree, 0);
if total = 0 then
avg_depth:= 0.0;
else
avg_depth:= Float(sum_depth) / Float(total);
end if;
end Tree_stat;
-- 13-May-2001: Find_first_offset
-- For an all-files unzipping of an appended (e.g. self-extracting) archive
-- (not beginning with ZIP contents), we cannot start with
-- index 1 in file.
-- But the offset of first entry in ZIP directory is not valid either,
-- as this excerpt of appnote.txt states:
-- " 4) The entries in the central directory may not necessarily
-- be in the same order that files appear in the zipfile. "
procedure Find_first_offset(
file : in out Zip_Streams.Root_Zipstream_Type'Class;
file_index : out Zip_Streams.ZS_Index_Type
)
is
the_end : Zip.Headers.End_of_Central_Dir;
header : Zip.Headers.Central_File_Header;
min_offset: File_size_type;
use Zip_Streams;
begin
Zip.Headers.Load(file, the_end);
Set_Index(
file,
ZS_Index_Type (1 + the_end.central_dir_offset) + the_end.offset_shifting
);
min_offset:= the_end.central_dir_offset; -- will be lowered if the archive is not empty.
if the_end.total_entries = 0 then
raise Archive_is_empty;
end if;
for i in 1..the_end.total_entries loop
Zip.Headers.Read_and_check(file, header );
Set_Index( file,
Index( file ) +
ZS_Size_Type
( header.short_info.filename_length +
header.short_info.extra_field_length +
header.comment_length
)
);
-- Now the whole i_th central directory entry is behind
if header.local_header_offset < min_offset then
min_offset:= header.local_header_offset;
end if;
end loop;
file_index:= Zip_Streams.ZS_Index_Type (1 + min_offset) + the_end.offset_shifting;
exception
when Zip.Headers.bad_end | Ada.IO_Exceptions.End_Error =>
Raise_Exception (Zip.Archive_corrupted'Identity, "Bad (or no) end-of-central-directory");
when Zip.Headers.bad_central_header =>
Raise_Exception (Zip.Archive_corrupted'Identity, "Bad central directory entry header");
end Find_first_offset;
-- Internal: find offset of a zipped file by reading sequentially the
-- central directory :-(
procedure Find_offset(
file : in out Zip_Streams.Root_Zipstream_Type'Class;
name : in String;
case_sensitive : in Boolean;
file_index : out Zip_Streams.ZS_Index_Type;
comp_size : out File_size_type;
uncomp_size : out File_size_type;
crc_32 : out Interfaces.Unsigned_32
)
is
the_end: Zip.Headers.End_of_Central_Dir;
header : Zip.Headers.Central_File_Header;
use Zip_Streams;
begin
Zip.Headers.Load(file, the_end);
Set_Index(file, ZS_Index_Type(1 + the_end.central_dir_offset) + the_end.offset_shifting);
for i in 1..the_end.total_entries loop
Zip.Headers.Read_and_check(file, header);
declare
this_name: String(1..Natural(header.short_info.filename_length));
begin
String'Read(file'Access, this_name);
Set_Index( file,
Index( file ) +
ZS_Size_Type(
header.short_info.extra_field_length +
header.comment_length
)
);
-- Now the whole i_th central directory entry is behind
if Normalize(this_name,case_sensitive) =
Normalize(name,case_sensitive)
then
-- Name found in central directory !
file_index := Zip_Streams.ZS_Index_Type (1 + header.local_header_offset) + the_end.offset_shifting;
comp_size := File_size_type(header.short_info.dd.compressed_size);
uncomp_size:= File_size_type(header.short_info.dd.uncompressed_size);
crc_32 := header.short_info.dd.crc_32;
return;
end if;
end;
end loop;
Raise_Exception (File_name_not_found'Identity, "Entry: [" & name & ']');
exception
when Zip.Headers.bad_end =>
Raise_Exception (Zip.Archive_corrupted'Identity, "Bad (or no) end-of-central-directory");
when Zip.Headers.bad_central_header =>
Raise_Exception (Zip.Archive_corrupted'Identity, "Bad central directory entry header");
end Find_offset;
-- Internal: find offset of a zipped file using the zip_info tree 8-)
procedure Find_offset(
info : in Zip_info;
name : in String;
name_encoding : out Zip_name_encoding;
file_index : out Zip_Streams.ZS_Index_Type;
comp_size : out File_size_type;
uncomp_size : out File_size_type;
crc_32 : out Interfaces.Unsigned_32
)
is
aux: p_Dir_node:= info.dir_binary_tree;
up_name: constant String:= Normalize(name, info.case_sensitive);
begin
if not info.loaded then
raise Forgot_to_load_zip_info;
end if;
while aux /= null loop
if up_name > aux.dico_name then
aux:= aux.right;
elsif up_name < aux.dico_name then
aux:= aux.left;
else -- entry found !
name_encoding := aux.name_encoding;
file_index := aux.file_index;
comp_size := aux.comp_size;
uncomp_size := aux.uncomp_size;
crc_32 := aux.crc_32;
return;
end if;
end loop;
Ada.Exceptions.Raise_Exception(
File_name_not_found'Identity,
"Archive: [" & info.zip_file_name.all & "], entry: [" & name & ']'
);
end Find_offset;
procedure Find_offset_without_directory(
info : in Zip_info;
name : in String;
name_encoding : out Zip_name_encoding;
file_index : out Zip_Streams.ZS_Index_Type;
comp_size : out File_size_type;
uncomp_size : out File_size_type;
crc_32 : out Interfaces.Unsigned_32
)
is
function Trash_dir( n: String ) return String is
idx: Integer:= n'First - 1;
begin
for i in n'Range loop
if n(i)= '/' or n(i)='\' then
idx:= i;
end if;
end loop;
-- idx points on the index just before the interesting part
return Normalize(n( idx+1 .. n'Last ), info.case_sensitive);
end Trash_dir;
simple_name: constant String:= Trash_dir(name);
Found: exception;
procedure Check_entry(
entry_name : String; -- 'name' is compressed entry's name
entry_index : Zip_Streams.ZS_Index_Type;
entry_comp_size : File_size_type;
entry_uncomp_size : File_size_type;
entry_crc_32 : Interfaces.Unsigned_32;
date_time : Time;
method : PKZip_method;
entry_name_encoding : Zip_name_encoding;
read_only : Boolean;
encrypted_2_x : Boolean; -- PKZip 2.x encryption
user_code : in out Integer
)
is
pragma Unreferenced (date_time, method, read_only, encrypted_2_x, user_code);
begin
if Trash_dir(entry_name) = simple_name then
name_encoding := entry_name_encoding;
file_index := entry_index;
comp_size := entry_comp_size;
uncomp_size := entry_uncomp_size;
crc_32 := entry_crc_32;
raise Found;
end if;
end Check_entry;
--
procedure Search is new Traverse_verbose(Check_entry);
--
begin
begin
Search(info);
exception
when Found =>
return;
end;
raise File_name_not_found;
end Find_offset_without_directory;
function Exists(
info : in Zip_info;
name : in String
)
return Boolean
is
aux: p_Dir_node:= info.dir_binary_tree;
up_name: constant String:= Normalize(name, info.case_sensitive);
begin
if not info.loaded then
raise Forgot_to_load_zip_info;
end if;
while aux /= null loop
if up_name > aux.dico_name then
aux:= aux.right;
elsif up_name < aux.dico_name then
aux:= aux.left;
else -- entry found !
return True;
end if;
end loop;
return False;
end Exists;
procedure Set_user_code(
info : in Zip_info;
name : in String;
code : in Integer
)
is
aux: p_Dir_node:= info.dir_binary_tree;
up_name: constant String:= Normalize(name, info.case_sensitive);
begin
if not info.loaded then
raise Forgot_to_load_zip_info;
end if;
while aux /= null loop
if up_name > aux.dico_name then
aux:= aux.right;
elsif up_name < aux.dico_name then
aux:= aux.left;
else -- entry found !
aux.user_code:= code;
return;
end if;
end loop;
Ada.Exceptions.Raise_Exception(
File_name_not_found'Identity,
"Archive: [" & info.zip_file_name.all & "], entry: [" & name & ']'
);
end Set_user_code;
function User_code(
info : in Zip_info;
name : in String
)
return Integer
is
aux: p_Dir_node:= info.dir_binary_tree;
up_name: constant String:= Normalize(name, info.case_sensitive);
begin
if not info.loaded then
raise Forgot_to_load_zip_info;
end if;
while aux /= null loop
if up_name > aux.dico_name then
aux:= aux.right;
elsif up_name < aux.dico_name then
aux:= aux.left;
else -- entry found !
return aux.user_code;
end if;
end loop;
Ada.Exceptions.Raise_Exception(
File_name_not_found'Identity,
"Archive: [" & info.zip_file_name.all & "], entry: [" & name & ']'
);
return 0; -- Fake, since exception has been raised just before. Removes an OA warning.
end User_code;
procedure Get_sizes(
info : in Zip_info;
name : in String;
comp_size : out File_size_type;
uncomp_size : out File_size_type
)
is
dummy_file_index: Zip_Streams.ZS_Index_Type;
dummy_name_encoding: Zip_name_encoding;
dummy_crc_32: Interfaces.Unsigned_32;
begin
Find_offset(
info, name, dummy_name_encoding, dummy_file_index,
comp_size, uncomp_size, dummy_crc_32
);
end Get_sizes;
-- Workaround for the severe xxx'Read xxx'Write performance
-- problems in the GNAT and ObjectAda compilers (as in 2009)
-- This is possible if and only if Byte = Stream_Element and
-- arrays types are both packed and aligned the same way.
--
subtype Size_test_a is Byte_Buffer(1..19);
subtype Size_test_b is Ada.Streams.Stream_Element_Array(1..19);
workaround_possible: constant Boolean:=
Size_test_a'Size = Size_test_b'Size and
Size_test_a'Alignment = Size_test_b'Alignment;
-- BlockRead - general-purpose procedure (nothing really specific
-- to Zip / UnZip): reads either the whole buffer from a file, or
-- if the end of the file lays inbetween, a part of the buffer.
procedure BlockRead(
file : in Ada.Streams.Stream_IO.File_Type;
buffer : out Byte_Buffer;
actually_read: out Natural
)
is
use Ada.Streams, Ada.Streams.Stream_IO;
SE_Buffer : Stream_Element_Array (1 .. buffer'Length);
for SE_Buffer'Address use buffer'Address;
pragma Import (Ada, SE_Buffer);
Last_Read : Stream_Element_Offset;
begin
if workaround_possible then
Read(Stream(file).all, SE_Buffer, Last_Read);
actually_read:= Natural(Last_Read);
else
if End_Of_File(file) then
actually_read:= 0;
else
actually_read:=
Integer'Min( buffer'Length, Integer(Size(file) - Index(file) + 1) );
Byte_Buffer'Read(
Stream(file),
buffer(buffer'First .. buffer'First + actually_read - 1)
);
end if;
end if;
end BlockRead;
procedure BlockRead(
stream : in out Zip_Streams.Root_Zipstream_Type'Class;
buffer : out Byte_Buffer;
actually_read: out Natural
)
is
use Ada.Streams, Zip_Streams;
SE_Buffer : Stream_Element_Array (1 .. buffer'Length);
for SE_Buffer'Address use buffer'Address;
pragma Import (Ada, SE_Buffer);
Last_Read : Stream_Element_Offset;
begin
if workaround_possible then
Read(stream, SE_Buffer, Last_Read);
actually_read:= Natural(Last_Read);
else
if End_Of_Stream(stream) then
actually_read:= 0;
else
actually_read:=
Integer'Min( buffer'Length, Integer(Size(stream) - Index(stream) + 1) );
Byte_Buffer'Read(
stream'Access,
buffer(buffer'First .. buffer'First + actually_read - 1)
);
end if;
end if;
end BlockRead;
procedure BlockRead(
stream : in out Zip_Streams.Root_Zipstream_Type'Class;
buffer : out Byte_Buffer
)
is
actually_read: Natural;
begin
BlockRead(stream, buffer, actually_read);
if actually_read < buffer'Length then
raise Ada.IO_Exceptions.End_Error;
end if;
end BlockRead;
procedure BlockWrite(
stream : in out Ada.Streams.Root_Stream_Type'Class;
buffer : in Byte_Buffer
)
is
use Ada.Streams;
SE_Buffer : Stream_Element_Array (1 .. buffer'Length);
for SE_Buffer'Address use buffer'Address;
pragma Import (Ada, SE_Buffer);
begin
if workaround_possible then
Ada.Streams.Write(stream, SE_Buffer);
else
Byte_Buffer'Write(stream'Access, buffer);
-- ^This is 30x to 70x slower on GNAT 2009 !
end if;
end BlockWrite;
function Image(m: PKZip_method) return String is
begin
case m is
when store => return "Store";
when shrink => return "Shrink";
when reduce_1 => return "Reduce 1";
when reduce_2 => return "Reduce 2";
when reduce_3 => return "Reduce 3";
when reduce_4 => return "Reduce 4";
when implode => return "Implode";
when tokenize => return "Tokenize";
when deflate => return "Deflate";
when deflate_e => return "Deflate64";
when bzip2 => return "BZip2";
when lzma_meth => return "LZMA";
when ppmd => return "PPMd";
when unknown => return "(unknown)";
end case;
end Image;
function Method_from_code(x: Natural) return PKZip_method is
-- An enumeration clause might be more elegant, but needs
-- curiously an Unchecked_Conversion... (RM 13.4)
begin
case x is
when compression_format_code.store => return store;
when compression_format_code.shrink => return shrink;
when compression_format_code.reduce => return reduce_1;
when compression_format_code.reduce + 1 => return reduce_2;
when compression_format_code.reduce + 2 => return reduce_3;
when compression_format_code.reduce + 3 => return reduce_4;
when compression_format_code.implode => return implode;
when compression_format_code.tokenize => return tokenize;
when compression_format_code.deflate => return deflate;
when compression_format_code.deflate_e => return deflate_e;
when compression_format_code.bzip2 => return bzip2;
when compression_format_code.lzma => return lzma_meth;
when compression_format_code.ppmd => return ppmd;
when others => return unknown;
end case;
end Method_from_code;
function Method_from_code(x: Interfaces.Unsigned_16) return PKZip_method is
begin
return Method_from_code(Natural(x));
end Method_from_code;
-- Copy a chunk from a stream into another one, using a temporary buffer
procedure Copy_chunk (
from : in out Zip_Streams.Root_Zipstream_Type'Class;
into : in out Ada.Streams.Root_Stream_Type'Class;
bytes : Natural;
buffer_size: Positive:= 1024*1024;
Feedback : Feedback_proc:= null
)
is
buf: Zip.Byte_Buffer(1..buffer_size);
actually_read, remains: Natural;
user_abort: Boolean:= False;
begin
remains:= bytes;
while remains > 0 loop
if Feedback /= null then
Feedback(
100 - Integer(100.0 * Float(remains) / Float(bytes)),
False,
user_abort
);
-- !! do something if user_abort = True !!
end if;
Zip.BlockRead(from, buf(1..Integer'Min(remains, buf'Last)), actually_read);
if actually_read = 0 then -- premature end, unexpected
raise Zip.Zip_file_Error;
end if;
remains:= remains - actually_read;
Zip.BlockWrite(into, buf(1..actually_read));
end loop;
end Copy_chunk;
-- Copy a whole file into a stream, using a temporary buffer
procedure Copy_file(
file_name : String;
into : in out Ada.Streams.Root_Stream_Type'Class;
buffer_size: Positive:= 1024*1024
)
is
use Ada.Streams.Stream_IO;
f: File_Type;
buf: Zip.Byte_Buffer(1..buffer_size);
actually_read: Natural;
begin
Open(f, In_File, file_name);
loop
Zip.BlockRead(f, buf, actually_read);
exit when actually_read = 0; -- this is expected
Zip.BlockWrite(into, buf(1..actually_read));
end loop;
Close(f);
end Copy_file;
-- This does the same as Ada 2005's Ada.Directories.Exists
-- Just there as helper for Ada 95 only systems
--
function Exists(name:String) return Boolean is
use Ada.Text_IO, Ada.Strings.Fixed;
f: File_Type;
begin
if Index(name, "*") > 0 then
return False;
end if;
Open(f,In_File,name, Form => Ada.Strings.Unbounded.To_String (Zip_Streams.Form_For_IO_Open_and_Create));
Close(f);
return True;
exception
when Name_Error =>
return False; -- The file cannot exist !
when Use_Error =>
return True; -- The file exist and is already opened !
end Exists;
procedure Put_Multi_Line(
out_file : Ada.Text_IO.File_Type;
text : String
)
is
last_char: Character:= ' ';
c: Character;
begin
for i in text'Range loop
c:= text(i);
case c is
when ASCII.CR =>
Ada.Text_IO.New_Line(out_file);
when ASCII.LF =>
if last_char /= ASCII.CR then Ada.Text_IO.New_Line(out_file); end if;
when others =>
Ada.Text_IO.Put(out_file, c);
end case;
last_char:= c;
end loop;
end Put_Multi_Line;
procedure Write_as_text(
out_file : Ada.Text_IO.File_Type;
buffer : Byte_Buffer;
last_char: in out Character -- track line-ending characters across writes
)
is
c: Character;
begin
for i in buffer'Range loop
c:= Character'Val(buffer(i));
case c is
when ASCII.CR =>
Ada.Text_IO.New_Line(out_file);
when ASCII.LF =>
if last_char /= ASCII.CR then Ada.Text_IO.New_Line(out_file); end if;
when others =>
Ada.Text_IO.Put(out_file, c);
end case;
last_char:= c;
end loop;
end Write_as_text;
function Hexadecimal(x: Interfaces.Unsigned_32) return String
is
package MIO is new Ada.Text_IO.Modular_IO(Interfaces.Unsigned_32);
str: String(1..12);
use Ada.Strings.Fixed;
begin
MIO.Put(str, x, 16);
return str(Index(str,"#")+1..11);
end Hexadecimal;
end Zip;
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.