with Ada.Characters.Handling;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Unchecked_Deallocation;
with Unchecked_Conversion;
with System; use System;
with GNAT.OS_Lib;
package body GNAT.Directory_Operations is
use Ada;
type Dir_Type_Value is new System.Address;
procedure Free is new
Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
function Base_Name
(Path : Path_Name;
Suffix : String := "")
return String
is
function Get_File_Names_Case_Sensitive return Integer;
pragma Import
(C, Get_File_Names_Case_Sensitive,
"__gnat_get_file_names_case_sensitive");
Case_Sensitive_File_Name : constant Boolean :=
Get_File_Names_Case_Sensitive = 1;
function Basename
(Path : Path_Name;
Suffix : String := "")
return String;
function Basename
(Path : Path_Name;
Suffix : String := "")
return String
is
Cut_Start : Natural :=
Strings.Fixed.Index
(Path, Dir_Seps, Going => Strings.Backward);
Cut_End : Natural;
begin
if Cut_Start = 0 then
Cut_Start := Path'First;
else
Cut_Start := Cut_Start + 1;
end if;
Cut_End := Path'Last;
if Suffix /= ""
and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
then
Cut_End := Path'Last - Suffix'Length;
end if;
Check_For_Standard_Dirs : declare
Offset : constant Integer := Path'First - Base_Name.Path'First;
BN : constant String :=
Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
begin
if BN = "." or else BN = ".." then
return "";
elsif BN'Length > 2
and then Characters.Handling.Is_Letter (BN (BN'First))
and then BN (BN'First + 1) = ':'
then
return BN (BN'First + 2 .. BN'Last);
else
return BN;
end if;
end Check_For_Standard_Dirs;
end Basename;
begin
if Case_Sensitive_File_Name then
return Basename (Path, Suffix);
else
return Basename
(Characters.Handling.To_Lower (Path),
Characters.Handling.To_Lower (Suffix));
end if;
end Base_Name;
procedure Change_Dir (Dir_Name : Dir_Name_Str) is
C_Dir_Name : String := Dir_Name & ASCII.NUL;
function chdir (Dir_Name : String) return Integer;
pragma Import (C, chdir, "chdir");
begin
if chdir (C_Dir_Name) /= 0 then
raise Directory_Error;
end if;
end Change_Dir;
procedure Close (Dir : in out Dir_Type) is
function closedir (Directory : System.Address) return Integer;
pragma Import (C, closedir, "closedir");
Discard : Integer;
begin
if not Is_Open (Dir) then
raise Directory_Error;
end if;
Discard := closedir (System.Address (Dir.all));
Free (Dir);
end Close;
function Dir_Name (Path : Path_Name) return Dir_Name_Str is
Last_DS : constant Natural :=
Strings.Fixed.Index
(Path, Dir_Seps, Going => Strings.Backward);
begin
if Last_DS = 0 then
return "." & Dir_Separator;
else
return Path (Path'First .. Last_DS);
end if;
end Dir_Name;
function Expand_Path (Path : Path_Name) return String is
Result : OS_Lib.String_Access := new String (1 .. 200);
Result_Last : Natural := 0;
procedure Append (C : Character);
procedure Append (S : String);
procedure Double_Result_Size;
procedure Read (K : in out Positive);
procedure Var (K : in out Positive);
procedure Append (C : Character) is
begin
if Result_Last = Result'Last then
Double_Result_Size;
end if;
Result_Last := Result_Last + 1;
Result (Result_Last) := C;
end Append;
procedure Append (S : String) is
begin
while Result_Last + S'Length - 1 > Result'Last loop
Double_Result_Size;
end loop;
Result (Result_Last + 1 .. Result_Last + S'Length) := S;
Result_Last := Result_Last + S'Length;
end Append;
procedure Double_Result_Size is
New_Result : constant OS_Lib.String_Access :=
new String (1 .. 2 * Result'Last);
begin
New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
OS_Lib.Free (Result);
Result := New_Result;
end Double_Result_Size;
procedure Read (K : in out Positive) is
begin
For_All_Characters : loop
if Path (K) = '$' then
if K < Path'Last then
if Path (K + 1) = '$' then
Append ('$');
K := K + 1;
else
K := K + 1;
Var (K);
end if;
else
Append ('$');
end if;
else
Append (Path (K));
end if;
K := K + 1;
exit For_All_Characters when K > Path'Last;
end loop For_All_Characters;
end Read;
procedure Var (K : in out Positive) is
E : Positive;
begin
if Path (K) = '{' then
E := K;
loop
E := E + 1;
exit when Path (E) = '}' or else E = Path'Last;
end loop;
if Path (E) = '}' then
declare
Env : OS_Lib.String_Access :=
OS_Lib.Getenv (Path (K + 1 .. E - 1));
begin
Append (Env.all);
OS_Lib.Free (Env);
end;
else
Append ('$');
Append (Path (K .. E));
end if;
else
E := K;
if Characters.Handling.Is_Letter (Path (E)) then
E := E + 1;
Var_Name : loop
exit Var_Name when E > Path'Last;
if Characters.Handling.Is_Letter (Path (E))
or else Characters.Handling.Is_Digit (Path (E))
then
E := E + 1;
else
exit Var_Name;
end if;
end loop Var_Name;
E := E - 1;
declare
Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
begin
Append (Env.all);
OS_Lib.Free (Env);
end;
else
Append ('$');
Append (Path (E));
end if;
end if;
K := E;
end Var;
begin
declare
K : Positive := Path'First;
begin
Read (K);
declare
Returned_Value : constant String := Result (1 .. Result_Last);
begin
OS_Lib.Free (Result);
return Returned_Value;
end;
end;
end Expand_Path;
function File_Extension (Path : Path_Name) return String is
First : Natural :=
Strings.Fixed.Index
(Path, Dir_Seps, Going => Strings.Backward);
Dot : Natural;
begin
if First = 0 then
First := Path'First;
end if;
Dot := Strings.Fixed.Index (Path (First .. Path'Last),
".",
Going => Strings.Backward);
if Dot = 0 or else Dot = Path'Last then
return "";
else
return Path (Dot .. Path'Last);
end if;
end File_Extension;
function File_Name (Path : Path_Name) return String is
begin
return Base_Name (Path);
end File_Name;
function Format_Pathname
(Path : Path_Name;
Style : Path_Style := System_Default)
return String
is
N_Path : String := Path;
K : Positive := N_Path'First;
Prev_Dirsep : Boolean := False;
begin
for J in Path'Range loop
if Strings.Maps.Is_In (Path (J), Dir_Seps) then
if not Prev_Dirsep then
case Style is
when UNIX => N_Path (K) := '/';
when DOS => N_Path (K) := '\';
when System_Default => N_Path (K) := Dir_Separator;
end case;
K := K + 1;
end if;
Prev_Dirsep := True;
else
N_Path (K) := Path (J);
K := K + 1;
Prev_Dirsep := False;
end if;
end loop;
return N_Path (N_Path'First .. K - 1);
end Format_Pathname;
Max_Path : Integer;
pragma Import (C, Max_Path, "__gnat_max_path_len");
function Get_Current_Dir return Dir_Name_Str is
Current_Dir : String (1 .. Max_Path + 1);
Last : Natural;
begin
Get_Current_Dir (Current_Dir, Last);
return Current_Dir (1 .. Last);
end Get_Current_Dir;
procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
Path_Len : Natural := Max_Path;
Buffer : String (Dir'First .. Dir'First + Max_Path + 1);
procedure Local_Get_Current_Dir
(Dir : System.Address;
Length : System.Address);
pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
begin
Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
if Dir'Length > Path_Len then
Last := Dir'First + Path_Len - 1;
else
Last := Dir'Last;
end if;
Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
end Get_Current_Dir;
function Is_Open (Dir : Dir_Type) return Boolean is
begin
return Dir /= Null_Dir
and then System.Address (Dir.all) /= System.Null_Address;
end Is_Open;
procedure Make_Dir (Dir_Name : Dir_Name_Str) is
C_Dir_Name : String := Dir_Name & ASCII.NUL;
function mkdir (Dir_Name : String) return Integer;
pragma Import (C, mkdir, "__gnat_mkdir");
begin
if mkdir (C_Dir_Name) /= 0 then
raise Directory_Error;
end if;
end Make_Dir;
procedure Open
(Dir : out Dir_Type;
Dir_Name : Dir_Name_Str)
is
C_File_Name : String := Dir_Name & ASCII.NUL;
function opendir
(File_Name : String)
return Dir_Type_Value;
pragma Import (C, opendir, "opendir");
begin
Dir := new Dir_Type_Value'(opendir (C_File_Name));
if not Is_Open (Dir) then
Free (Dir);
Dir := Null_Dir;
raise Directory_Error;
end if;
end Open;
procedure Read
(Dir : in out Dir_Type;
Str : out String;
Last : out Natural)
is
Filename_Addr : Address;
Filename_Len : Integer;
Buffer : array (0 .. 1024) of Character;
function readdir_gnat
(Directory : System.Address;
Buffer : System.Address)
return System.Address;
pragma Import (C, readdir_gnat, "__gnat_readdir");
function strlen (S : Address) return Integer;
pragma Import (C, strlen, "strlen");
begin
if not Is_Open (Dir) then
raise Directory_Error;
end if;
Filename_Addr :=
readdir_gnat (System.Address (Dir.all), Buffer'Address);
if Filename_Addr = System.Null_Address then
Last := 0;
return;
end if;
Filename_Len := strlen (Filename_Addr);
if Str'Length > Filename_Len then
Last := Str'First + Filename_Len - 1;
else
Last := Str'Last;
end if;
declare
subtype Path_String is String (1 .. Filename_Len);
type Path_String_Access is access Path_String;
function Address_To_Access is new
Unchecked_Conversion
(Source => Address,
Target => Path_String_Access);
Path_Access : Path_String_Access := Address_To_Access (Filename_Addr);
begin
for J in Str'First .. Last loop
Str (J) := Path_Access (J - Str'First + 1);
end loop;
end;
end Read;
function Read_Is_Thread_Safe return Boolean is
function readdir_is_thread_safe return Integer;
pragma Import
(C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
begin
return (readdir_is_thread_safe /= 0);
end Read_Is_Thread_Safe;
procedure Remove_Dir (Dir_Name : Dir_Name_Str) is
C_Dir_Name : String := Dir_Name & ASCII.NUL;
procedure rmdir (Dir_Name : String);
pragma Import (C, rmdir, "rmdir");
begin
rmdir (C_Dir_Name);
end Remove_Dir;
end GNAT.Directory_Operations;