File : filepack.adb
------------------------------------------------------------------------------
-- ADAGIO - ADALID - AENEA. --
-- --
-- Copyright (C) 2003 --
-- A. Mosteo. --
-- --
-- Authors: A. Mosteo. (adagio@mosteo.com) --
-- --
-- If you have any questions in regard to this software, please address --
-- them to the above email. --
-- --
-- This program is free software; you can redistribute it and/or modify --
-- it under the terms of the GNU General Public License as published by --
-- the Free Software Foundation; either version 2 of the License, or (at --
-- your option) any later version. --
-- --
-- This program is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- General Public License for more details. --
-- --
-- You should have received a copy of the GNU General Public License --
-- along with this library; if not, write to the Free Software Foundation, --
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- You are not allowed to use any part of this code to develop a program --
-- whose output would be used to harass or prosecute other users of the --
-- networks Adagio connects with. All data collected with Adagio or a tool --
-- containing Adagio code about other network users must remain --
-- confidential and cannot be made public by any mean, nor be used to --
-- harass or legally prosecute these users. --
------------------------------------------------------------------------------
-- Facilities to pack separate entities as a single file.
with Ada.Strings.Unbounded;
use Ada.Strings.Unbounded;
with Gnat.Os_lib; use Gnat.Os_lib;
package body Filepack is
use Entry_map;
type File_entry_access is access all File_entry;
function Element_ref is new Generic_element (File_entry_access);
procedure Check_opened (This : in Object);
-- Overriden primitives:
procedure Read(
Stream : in out Stream_type;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset) is
begin
Check_opened (Stream.Parent.all);
if Stream.Parent.Mode /= Read and then Stream.Parent.Mode /= Both then
raise Access_mode_error;
end if;
if Stream.Parent.Remaining = 0 then
raise Index_out_of_bounds;
end if;
Read (
Stream.Parent.FS.all,
Item (
Item'First ..
Stream_element_offset'Min (
Item'Last,
Item'First + Stream_element_offset (
Stream.Parent.Remaining - 1))),
Last);
end Read;
procedure Write(
Stream : in out Stream_type;
Item : in Stream_Element_Array) is
begin
Check_opened (Stream.Parent.all);
if Stream.Parent.Mode /= Write and then Stream.Parent.Mode /= Both then
raise Access_mode_error;
end if;
Write (Stream.Parent.FS.all, Item);
Stream.Parent.Total_data := Stream.Parent.Total_data + Item'Length;
Stream.Parent.Current.Size := Stream.Parent.Current.Size + Item'Length;
end Write;
------------------------------------------------------------------------
-- Check_opened --
------------------------------------------------------------------------
procedure Check_opened (This : in Object) is
begin
if not This.Bound then
raise Filepack_not_bound;
end if;
if not This.Found then
raise File_not_open;
end if;
end Check_opened;
------------------------------------------------------------------------
-- Create_index --
------------------------------------------------------------------------
procedure Create_index (This : in out Object) is
use Stream_io;
Stream : Stream_access := Stream_io.Stream (This.F);
procedure Read_entry is
E : File_entry;
begin
-- Text_io.Put_line ("Index: " & Stream_io.Count'Image (Index (This.F)));
-- Text_io.Put_line ("Size : " & Stream_io.Count'Image (Size (This.F)));
E.Header_offset := Positive (Index (This.F));
Unbounded_string'Read (Stream, E.Name);
-- Text_io.Put_line ("Read: " & To_string (E.Name));
Natural'Read (Stream, E.Size);
-- Text_io.Put_line ("Size:" & E.Size'Img);
Boolean'Read (Stream, E.Deleted);
-- Text_io.Put_line ("Del :" & E.Deleted'Img);
E.Offset := Positive (Index (This.F));
-- Skip data:
if E.Size > 0 then
Set_index (This.F, Index (This.F) + Positive_Count (E.Size));
end if;
This.Total_data := This.Total_data + E.Size;
if not E.Deleted then
Insert (This.Index, To_string (E.Name), E);
else
This.Wasted_data :=
This.Wasted_data + E.size;
end if;
end Read_entry;
begin
This.Wasted_data := 0;
while not End_of_file (This.F) loop
Read_entry;
end loop;
end Create_index;
------------------------------------------------------------------------
-- Bind --
------------------------------------------------------------------------
-- Opens or creates a filepack. It's opened always in Append mode.
procedure Bind (This : out Object; Name : in String) is
use Stream_io;
Success : Boolean;
begin
if not Is_regular_file (Name) and then
Is_regular_file (Name & ".tmp")
then
Rename_file (Name & ".tmp", Name, Success);
if not Success then
raise Unknown_error;
end if;
end if;
if Is_regular_file (Name) then
Open (This.F, Name => Name, Mode => In_file);
else
Create (This.F, Name => Name, Mode => Out_file);
Close (This.F);
Open (This.F, Name => Name, Mode => In_file);
end if;
Create_index (This);
Close (This.F);
This.Bound := true;
This.Found := false;
This.Name := To_unbounded_string (Name);
This.Stream_access := This.Stream'Unchecked_Access;
end Bind;
------------------------------------------------------------------------
-- Unbind --
------------------------------------------------------------------------
-- Cuts the link with a filepack.
procedure Unbind (This : in out Object) is
use Stream_io;
begin
if This.Bound then
if this.Found then
Close (This);
end if;
Clear (This.Index);
This.Bound := false;
end if;
end Unbind;
------------------------------------------------------------------------
-- Open --
------------------------------------------------------------------------
-- Opens a file inside the filepack. May raise File_not_found
-- Opening a new file don't need to close the previous.
procedure Open (This : in out Object; Name : in String) is
I : Iterator_type;
use Stream_io;
begin
if not This.Bound then
raise Filepack_not_bound;
end if;
if This.Found then
Close (This);
end if;
I := Find (This.Index, Name);
if I = Back (This.Index) then
raise File_not_found;
else
Open (This.F, Name => To_string (This.Name), Mode => In_file);
This.Current := Element (I);
This.Mode := Read;
This.Found := true;
This.Remaining := This.Current.Size;
Set_index (This.F, Positive_count (This.Current.Offset));
This.FS := Stream (This.F);
end if;
end Open;
------------------------------------------------------------------------
-- Write_entry --
------------------------------------------------------------------------
-- Writes a file entry at current stream position:
procedure Write_entry (
Stream : in Stream_io.Stream_access; E : in File_entry) is
begin
Unbounded_string'Write (Stream, E.Name);
Natural'Write (Stream, E.Size);
-- Text_io.Put_line ("Writing Size:" & E.Size'Img);
Boolean'write (Stream, E.Deleted);
-- Text_io.Put_line ("Writing Dele:" & E.Deleted'Img);
end Write_entry;
------------------------------------------------------------------------
-- Create --
------------------------------------------------------------------------
-- Create a new file inside the filepack.
-- May raise File_already_exists.
-- The created file remains opened.
procedure Create (This : in out Object; Name : in String) is
use Stream_io;
begin
if not This.Bound then
raise Filepack_not_bound;
end if;
-- Close another previous open.
if This.Found then
Close (This);
end if;
if Is_in (Name, This.Index) then
raise File_already_exists;
end if;
Open (This.F, Name => To_string (This.Name), Mode => Append_file);
This.Current.Name := To_unbounded_string (Name);
This.Current.Deleted := false;
This.Current.size := 0;
Set_index (This.F, Size (This.F) + 1);
This.Current.Header_offset := Natural (Index (This.F));
Write_entry (Stream (This.F), This.Current);
This.Current.Offset := Natural (Index (This.F));
This.Mode := Write;
This.Found := true;
This.FS := Stream (This.F);
Insert (This.Index, Name, This.Current);
end Create;
------------------------------------------------------------------------
-- Delete --
------------------------------------------------------------------------
-- Marks the opened file as deleted.
procedure Delete (This : in out Object) is
use Stream_io;
begin
Check_opened (This);
This.Current.Deleted := true;
Close (This.F);
Open (This.F, Name => To_string (This.Name), Mode => Append_file);
Set_index (This.F, Positive_count (This.Current.Header_offset));
Write_entry (Stream (This.F), This.Current);
Close (This.F);
This.Found := false;
This.Wasted_data := This.Wasted_data + This.Current.Size;
Delete (This.Index, To_string (This.Current.Name));
end Delete;
------------------------------------------------------------------------
-- Delete --
------------------------------------------------------------------------
-- Marks the named file as deleted.
procedure Delete (This : in out Object; Name : in String) is
begin
Open (This, Name);
Delete (This);
end Delete;
------------------------------------------------------------------------
-- Close --
------------------------------------------------------------------------
-- Commits changes in a file opened for writing.
procedure Close (This : in out Object) is
use Stream_io;
begin
Check_opened (This);
if This.Mode = Write or else This.Mode = Both then
Set_index (This.F, Positive_count (This.Current.Header_offset));
Write_entry (Stream (This.F), This.Current);
Flush (This.F);
Insert (This.Index, To_string (This.Current.Name), This.Current);
end if;
Close (This.F);
This.Found := false;
end Close;
------------------------------------------------------------------------
-- Contains --
------------------------------------------------------------------------
-- Says if a certain file is in the filepack
function Contains (This : in Object; Name : in String) return Boolean is
begin
return Is_in (Name, This.Index);
end Contains;
------------------------------------------------------------------------
-- Is_open --
------------------------------------------------------------------------
-- Says if some file is open
function Is_open (This : in Object) return Boolean is
begin
return This.Found;
end Is_open;
------------------------------------------------------------------------
-- Set_index --
------------------------------------------------------------------------
-- Sets the starting position. A file must have been opened.
-- May raise Index_out_of_bounds or File_not_open
procedure Set_index (This : in out Object; Index : in Positive) is
use Stream_io;
begin
Check_opened (This);
if This.Mode /= Read then
raise Access_mode_error;
end if;
if Index > This.Current.Size + 1 then
raise Index_out_of_bounds;
end if;
Set_index (This.F, Positive_count (This.Current.Offset + Index - 1));
end Set_index;
------------------------------------------------------------------------
-- Size --
------------------------------------------------------------------------
-- Gets the size of the currently opened file (not the filepack)
-- May raise File_not_open
function Size (This : in Object) return Natural is
begin
Check_opened (This);
return This.Current.Size;
end Size;
------------------------------------------------------------------------
-- End_of_file --
------------------------------------------------------------------------
-- Says if the current opened underlying file has reached EOF
function End_of_file (This : in Object) return Boolean is
use Stream_io;
begin
Check_opened (This);
return Index (This.F) >
Positive_count (This.Current.Offset + This.Current.Size - 1);
end End_of_file;
------------------------------------------------------------------------
-- Stream --
------------------------------------------------------------------------
-- Gets an stream for the current opened file.
-- If the file was opened, only read is allowed.
-- If the file was created, only writing is allowed.
function Stream (This : in Object) return
Ada.Streams.Stream_io.Stream_access is
begin
Check_opened (This);
return This.Stream_access;
end Stream;
------------------------------------------------------------------------
-- Wasted --
------------------------------------------------------------------------
-- Returns the per one wasted proportion due to deleted files
function Wasted (This : in Object) return Wasted_percent is
begin
if not This.Bound then
raise Filepack_not_bound;
end if;
if This.Total_data = 0 then
return 1.0;
else
return Float (This.Wasted_data) / Float (This.Total_data);
end if;
end Wasted;
------------------------------------------------------------------------
-- Purge --
------------------------------------------------------------------------
-- Recreates the filepack to achieve a 0.0 of wasted space.
-- The current file will be closed.
procedure Purge (This : in out Object) is
use Stream_io;
Success : Boolean;
Alias : Object;
begin
if not This.Bound then
raise Filepack_not_bound;
end if;
if This.Found then
close (This);
end if;
declare
Alias_name : String := To_string (This.Name) & ".tmp";
F : File_type;
Sin : Stream_access;
Sout : Stream_access;
I : Iterator_type := First (This.Index);
E : File_entry;
Buffer : Stream_element_array (1 .. 1024);
Last : Stream_element_offset;
begin
if Is_regular_file (Alias_name) then
Delete_file (Alias_name, Success);
if not Success then
raise Unknown_error;
end if;
end if;
Bind (Alias, Alias_name);
while I /= Back (This.Index) loop
E := Element (I);
Open (This, To_string (E.Name));
Create (Alias, To_string (E.Name));
Sin := Stream (This);
Sout := Stream (Alias);
while not End_of_file (This) loop
Read (Sin.all, Buffer, Last);
Write (Sout.all, Buffer (Buffer'First .. Last));
end loop;
I := Succ (I);
end loop;
Unbind (Alias);
Unbind (This);
Delete_file (To_string (This.Name), Success);
if not Success then
raise Unknown_error;
end if;
Rename_file (Alias_name, To_string (This.Name), Success);
if not Success then
raise Unknown_error;
end if;
end;
-- The end: rebinding
Bind (This, To_string (This.Name));
end Purge;
------------------------------------------------------------------------
-- Mark_deletable --
------------------------------------------------------------------------
-- To do a selective purge, this procedure marks files as deletables.
-- No name implies all files.
-- See Mark_not_deletable
procedure Mark_deletable (This : in out Object; Name : in String := "") is
I : Iterator_type := First (This.Index);
begin
if Name /= "" then
I := Find (This.Index, Name);
Element_ref (I).Deletable := true;
else
while I /= Back (This.Index) loop
Element_ref (I).Deletable := true;
I := Succ (I);
end loop;
end if;
end Mark_deletable;
------------------------------------------------------------------------
-- Mark_not_deletable --
------------------------------------------------------------------------
-- Marks a file (or all) as not candidate for deleting
procedure Mark_not_deletable (
This : in out Object; Name : in String := "") is
I : Iterator_type := First (This.Index);
begin
if Name /= "" then
I := Find (This.Index, Name);
Element_ref (I).Deletable := false;
else
while I /= Back (This.Index) loop
Element_ref (I).Deletable := false;
I := Succ (I);
end loop;
end if;
end Mark_not_deletable;
------------------------------------------------------------------------
-- Delete_marked --
------------------------------------------------------------------------
-- This effectively deletes all marked files.
procedure Delete_marked (This : in out Object) is
I : Iterator_type := First (This.Index);
N : Iterator_type;
begin
while I /= Back (This.Index) loop
N := Succ (I);
if Element (I).Deletable then
Delete (This, To_string (Element (I).Name));
end if;
I := N;
end loop;
end Delete_marked;
------------------------------------------------------------------------
-- Export --
------------------------------------------------------------------------
-- Exports a file from the filepack, giving an open for read File_type.
-- If no name is supplied, the file will be temporary.
procedure Export (
This : in out Object;
Name : in String;
To : in out Stream_io.File_type;
To_name : in String := "") is
use Stream_io;
Buffer : Stream_element_array (1 .. 1024);
Last : Stream_element_offset;
Sin,
Sout : Stream_access;
begin
Open (This, Name);
Open (To, Mode => Out_file, Name => To_name);
Sin := Stream (This);
Sout := Stream (To);
while not End_of_file (This) loop
Read (Sin.all, Buffer, Last);
Write (Sout.all, Buffer (1 .. Last));
end loop;
Close (This);
Set_mode (To, In_file);
Set_index (To, 1);
end Export;
end Filepack;