with Ada.Directories.Validity; use Ada.Directories.Validity;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Regexp; use GNAT.Regexp;
with System;
package body Ada.Directories is
type Search_Data is record
Is_Valid : Boolean := False;
Name : Ada.Strings.Unbounded.Unbounded_String;
Pattern : Regexp;
Filter : Filter_Type;
Dir : Dir_Type;
Entry_Fetched : Boolean := False;
Dir_Entry : Directory_Entry_Type;
end record;
Empty_String : constant String := (1 .. 0 => ASCII.NUL);
procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
function File_Exists (Name : String) return Boolean;
procedure Fetch_Next_Entry (Search : Search_Type);
procedure To_Lower_If_Case_Insensitive (S : in out String);
function Base_Name (Name : String) return String is
Simple : String := Simple_Name (Name);
begin
To_Lower_If_Case_Insensitive (Simple);
for Pos in reverse Simple'Range loop
if Simple (Pos) = '.' then
return Simple (1 .. Pos - 1);
end if;
end loop;
return Simple;
end Base_Name;
function Compose
(Containing_Directory : String := "";
Name : String;
Extension : String := "") return String
is
Result : String (1 .. Containing_Directory'Length +
Name'Length + Extension'Length + 2);
Last : Natural;
begin
if not Is_Valid_Path_Name (Containing_Directory) then
raise Name_Error;
elsif
Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
then
raise Name_Error;
elsif Extension'Length /= 0 and then
(not Is_Valid_Simple_Name (Name & '.' & Extension))
then
raise Name_Error;
else
Last := Containing_Directory'Length;
Result (1 .. Last) := Containing_Directory;
if Result (Last) /= Dir_Separator then
Last := Last + 1;
Result (Last) := Dir_Separator;
end if;
Result (Last + 1 .. Last + Name'Length) := Name;
Last := Last + Name'Length;
if Extension'Length /= 0 then
Last := Last + 1;
Result (Last) := '.';
Result (Last + 1 .. Last + Extension'Length) := Extension;
Last := Last + Extension'Length;
end if;
To_Lower_If_Case_Insensitive (Result (1 .. Last));
return Result (1 .. Last);
end if;
end Compose;
function Containing_Directory (Name : String) return String is
begin
if not Is_Valid_Path_Name (Name) then
raise Name_Error;
else
declare
Value : constant String := Dir_Name (Path => Name);
Result : String (1 .. Value'Length);
Last : Natural := Result'Last;
begin
Result := Value;
while Last > 1 and then Result (Last) = Dir_Separator loop
Last := Last - 1;
end loop;
if Last = 1 and then Result (1) = '.' then
return Get_Current_Dir;
else
To_Lower_If_Case_Insensitive (Result (1 .. Last));
return Result (1 .. Last);
end if;
end;
end if;
end Containing_Directory;
procedure Copy_File
(Source_Name : String;
Target_Name : String;
Form : String := "")
is
pragma Unreferenced (Form);
Success : Boolean;
begin
if not Is_Valid_Path_Name (Source_Name)
or else not Is_Valid_Path_Name (Target_Name)
or else not Is_Regular_File (Source_Name)
then
raise Name_Error;
elsif Is_Directory (Target_Name) then
raise Use_Error;
else
Copy_File
(Source_Name, Target_Name, Success, Overwrite, None);
if not Success then
raise Use_Error;
end if;
end if;
end Copy_File;
procedure Create_Directory
(New_Directory : String;
Form : String := "")
is
pragma Unreferenced (Form);
begin
if not Is_Valid_Path_Name (New_Directory) then
raise Name_Error;
else
begin
Make_Dir (Dir_Name => New_Directory);
exception
when Directory_Error =>
raise Use_Error;
end;
end if;
end Create_Directory;
procedure Create_Path
(New_Directory : String;
Form : String := "")
is
pragma Unreferenced (Form);
New_Dir : String (1 .. New_Directory'Length + 1);
Last : Positive := 1;
begin
if not Is_Valid_Path_Name (New_Directory) then
raise Name_Error;
else
New_Dir (1 .. New_Directory'Length) := New_Directory;
New_Dir (New_Dir'Last) := Directory_Separator;
for J in 2 .. New_Dir'Last loop
if New_Dir (J) /= Dir_Separator then
Last := J;
elsif New_Dir (J - 1) /= Dir_Separator then
if Is_Directory (New_Dir (1 .. Last)) then
null;
elsif Is_Regular_File (New_Dir (1 .. Last)) then
raise Use_Error;
else
begin
Make_Dir (Dir_Name => New_Dir (1 .. Last));
exception
when Directory_Error =>
raise Use_Error;
end;
end if;
end if;
end loop;
end if;
end Create_Path;
function Current_Directory return String is
Cur : String := Normalize_Pathname (Get_Current_Dir);
begin
To_Lower_If_Case_Insensitive (Cur);
if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
return Cur (1 .. Cur'Last - 1);
else
return Cur;
end if;
end Current_Directory;
procedure Delete_Directory (Directory : String) is
begin
if not Is_Valid_Path_Name (Directory) then
raise Name_Error;
elsif not Is_Directory (Directory) then
raise Name_Error;
else
begin
Remove_Dir (Dir_Name => Directory, Recursive => False);
exception
when Directory_Error =>
raise Use_Error;
end;
end if;
end Delete_Directory;
procedure Delete_File (Name : String) is
Success : Boolean;
begin
if not Is_Valid_Path_Name (Name) then
raise Name_Error;
elsif not Is_Regular_File (Name) then
raise Name_Error;
else
Delete_File (Name, Success);
if not Success then
raise Use_Error;
end if;
end if;
end Delete_File;
procedure Delete_Tree (Directory : String) is
begin
if not Is_Valid_Path_Name (Directory) then
raise Name_Error;
elsif not Is_Directory (Directory) then
raise Name_Error;
else
begin
Remove_Dir (Directory, Recursive => True);
exception
when Directory_Error =>
raise Use_Error;
end;
end if;
end Delete_Tree;
function Exists (Name : String) return Boolean is
begin
if not Is_Valid_Path_Name (Name) then
raise Name_Error;
else
return File_Exists (Name);
end if;
end Exists;
function Extension (Name : String) return String is
begin
if not Is_Valid_Path_Name (Name) then
raise Name_Error;
else
for Pos in reverse Name'Range loop
if Name (Pos) = Dir_Separator then
return Empty_String;
elsif Name (Pos) = '.' then
declare
Result : String (1 .. Name'Last - Pos);
begin
Result := Name (Pos + 1 .. Name'Last);
return Result;
end;
end if;
end loop;
return Empty_String;
end if;
end Extension;
procedure Fetch_Next_Entry (Search : Search_Type) is
Name : String (1 .. 255);
Last : Natural;
Kind : File_Kind := Ordinary_File;
begin
loop
Read (Search.Value.Dir, Name, Last);
if Last = 0 then
Search.Value.Is_Valid := False;
exit;
end if;
if Match (Name (1 .. Last), Search.Value.Pattern) then
declare
Full_Name : constant String :=
Compose
(To_String
(Search.Value.Name), Name (1 .. Last));
Found : Boolean := False;
begin
if File_Exists (Full_Name) then
if Is_Regular_File (Full_Name) then
if Search.Value.Filter (Ordinary_File) then
Kind := Ordinary_File;
Found := True;
end if;
elsif Is_Directory (Full_Name) then
if Search.Value.Filter (Directory) then
Kind := Directory;
Found := True;
end if;
elsif Search.Value.Filter (Special_File) then
Kind := Special_File;
Found := True;
end if;
if Found then
Search.Value.Entry_Fetched := True;
Search.Value.Dir_Entry :=
(Is_Valid => True,
Simple => To_Unbounded_String (Name (1 .. Last)),
Full => To_Unbounded_String (Full_Name),
Kind => Kind);
exit;
end if;
end if;
end;
end if;
end loop;
end Fetch_Next_Entry;
function File_Exists (Name : String) return Boolean is
function C_File_Exists (A : System.Address) return Integer;
pragma Import (C, C_File_Exists, "__gnat_file_exists");
C_Name : String (1 .. Name'Length + 1);
begin
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
return C_File_Exists (C_Name (1)'Address) = 1;
end File_Exists;
procedure Finalize (Search : in out Search_Type) is
begin
if Search.Value /= null then
if Is_Open (Search.Value.Dir) then
Close (Search.Value.Dir);
end if;
Free (Search.Value);
end if;
end Finalize;
function Full_Name (Name : String) return String is
begin
if not Is_Valid_Path_Name (Name) then
raise Name_Error;
else
declare
Value : String := Normalize_Pathname (Name);
subtype Result is String (1 .. Value'Length);
begin
To_Lower_If_Case_Insensitive (Value);
return Result (Value);
end;
end if;
end Full_Name;
function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
begin
if not Directory_Entry.Is_Valid then
raise Status_Error;
else
return To_String (Directory_Entry.Full);
end if;
end Full_Name;
procedure Get_Next_Entry
(Search : in out Search_Type;
Directory_Entry : out Directory_Entry_Type)
is
begin
if Search.Value = null or else not Search.Value.Is_Valid then
raise Status_Error;
end if;
if not Search.Value.Entry_Fetched then
Fetch_Next_Entry (Search);
end if;
if not Search.Value.Is_Valid then
raise Status_Error;
else
Search.Value.Entry_Fetched := False;
Directory_Entry := Search.Value.Dir_Entry;
end if;
end Get_Next_Entry;
function Kind (Name : String) return File_Kind is
begin
if not File_Exists (Name) then
raise Name_Error;
elsif Is_Regular_File (Name) then
return Ordinary_File;
elsif Is_Directory (Name) then
return Directory;
else
return Special_File;
end if;
end Kind;
function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
begin
if not Directory_Entry.Is_Valid then
raise Status_Error;
else
return Directory_Entry.Kind;
end if;
end Kind;
function Modification_Time (Name : String) return Ada.Calendar.Time is
Date : OS_Time;
Year : Year_Type;
Month : Month_Type;
Day : Day_Type;
Hour : Hour_Type;
Minute : Minute_Type;
Second : Second_Type;
begin
if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
raise Name_Error;
else
Date := File_Time_Stamp (Name);
GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
return Ada.Calendar.Time_Of
(Year, Month, Day, Duration (Second + 60 * (Minute + 60 * Hour)));
end if;
end Modification_Time;
function Modification_Time
(Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
is
begin
if not Directory_Entry.Is_Valid then
raise Status_Error;
else
return Modification_Time (To_String (Directory_Entry.Full));
end if;
end Modification_Time;
function More_Entries (Search : Search_Type) return Boolean is
begin
if Search.Value = null then
return False;
elsif Search.Value.Is_Valid then
if not Search.Value.Entry_Fetched then
Fetch_Next_Entry (Search);
end if;
end if;
return Search.Value.Is_Valid;
end More_Entries;
procedure Rename (Old_Name, New_Name : String) is
Success : Boolean;
begin
if not Is_Valid_Path_Name (Old_Name)
or else not Is_Valid_Path_Name (New_Name)
or else (not Is_Regular_File (Old_Name)
and then not Is_Directory (Old_Name))
then
raise Name_Error;
elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then
raise Use_Error;
else
Rename_File (Old_Name, New_Name, Success);
if not Success then
raise Use_Error;
end if;
end if;
end Rename;
procedure Set_Directory (Directory : String) is
begin
Change_Dir (Dir_Name => Directory);
exception
when Directory_Error =>
raise Name_Error;
end Set_Directory;
function Simple_Name (Name : String) return String is
begin
if not Is_Valid_Path_Name (Name) then
raise Name_Error;
else
declare
Value : String := GNAT.Directory_Operations.Base_Name (Name);
subtype Result is String (1 .. Value'Length);
begin
To_Lower_If_Case_Insensitive (Value);
return Result (Value);
end;
end if;
end Simple_Name;
function Simple_Name
(Directory_Entry : Directory_Entry_Type) return String
is
begin
if not Directory_Entry.Is_Valid then
raise Status_Error;
else
return To_String (Directory_Entry.Simple);
end if;
end Simple_Name;
function Size (Name : String) return File_Size is
C_Name : String (1 .. Name'Length + 1);
function C_Size (Name : System.Address) return Long_Integer;
pragma Import (C, C_Size, "__gnat_named_file_length");
begin
if not Is_Regular_File (Name) then
raise Name_Error;
else
C_Name (1 .. Name'Length) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
return File_Size (C_Size (C_Name'Address));
end if;
end Size;
function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
begin
if not Directory_Entry.Is_Valid then
raise Status_Error;
else
return Size (To_String (Directory_Entry.Full));
end if;
end Size;
procedure Start_Search
(Search : in out Search_Type;
Directory : String;
Pattern : String;
Filter : Filter_Type := (others => True))
is
begin
if not Is_Directory (Directory) then
raise Name_Error;
end if;
Finalize (Search);
Search.Value := new Search_Data;
begin
Search.Value.Pattern := Compile (Pattern, Glob => True);
exception
when Error_In_Regexp =>
raise Name_Error;
end;
Search.Value.Filter := Filter;
Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
Open (Search.Value.Dir, Directory);
Search.Value.Is_Valid := True;
end Start_Search;
procedure To_Lower_If_Case_Insensitive (S : in out String) is
begin
if not Is_Path_Name_Case_Sensitive then
for J in S'Range loop
S (J) := To_Lower (S (J));
end loop;
end if;
end To_Lower_If_Case_Insensitive;
end Ada.Directories;