with Namet; use Namet;
with Osint; use Osint;
with Sdefault;
with Types; use Types;
with GNAT.HTable;
with GNAT.OS_Lib; use GNAT.OS_Lib;
package body Prj.Ext is
Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
No_Project_Default_Dir : constant String := "-";
Current_Project_Path : String_Access;
package Htable is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
Element => Name_Id,
No_Element => No_Name,
Key => Name_Id,
Hash => Hash,
Equal => "=");
procedure Add
(External_Name : String;
Value : String)
is
The_Key : Name_Id;
The_Value : Name_Id;
begin
Name_Len := Value'Length;
Name_Buffer (1 .. Name_Len) := Value;
The_Value := Name_Find;
Name_Len := External_Name'Length;
Name_Buffer (1 .. Name_Len) := External_Name;
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
The_Key := Name_Find;
Htable.Set (The_Key, The_Value);
end Add;
function Check (Declaration : String) return Boolean is
begin
for Equal_Pos in Declaration'Range loop
if Declaration (Equal_Pos) = '=' then
exit when Equal_Pos = Declaration'First;
exit when Equal_Pos = Declaration'Last;
Add
(External_Name =>
Declaration (Declaration'First .. Equal_Pos - 1),
Value =>
Declaration (Equal_Pos + 1 .. Declaration'Last));
return True;
end if;
end loop;
return False;
end Check;
function Project_Path return String is
begin
return Current_Project_Path.all;
end Project_Path;
procedure Reset is
begin
Htable.Reset;
end Reset;
procedure Set_Project_Path (New_Path : String) is
begin
Free (Current_Project_Path);
Current_Project_Path := new String'(New_Path);
end Set_Project_Path;
function Value_Of
(External_Name : Name_Id;
With_Default : Name_Id := No_Name)
return Name_Id
is
The_Value : Name_Id;
Name : String := Get_Name_String (External_Name);
begin
Canonical_Case_File_Name (Name);
Name_Len := Name'Length;
Name_Buffer (1 .. Name_Len) := Name;
The_Value := Htable.Get (Name_Find);
if The_Value /= No_Name then
return The_Value;
end if;
declare
Env_Value : String_Access := Getenv (Name);
begin
if Env_Value /= null and then Env_Value'Length > 0 then
Name_Len := Env_Value'Length;
Name_Buffer (1 .. Name_Len) := Env_Value.all;
The_Value := Name_Find;
Htable.Set (External_Name, The_Value);
Free (Env_Value);
return The_Value;
else
Free (Env_Value);
return With_Default;
end if;
end;
end Value_Of;
begin
declare
Add_Default_Dir : Boolean := True;
First : Positive;
Last : Positive;
begin
Name_Len := 1;
Name_Buffer (Name_Len) := '.';
if Prj_Path.all /= "" then
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Path_Separator;
Add_Str_To_Name_Buffer (Prj_Path.all);
First := 3;
loop
while First <= Name_Len
and then (Name_Buffer (First) = Path_Separator)
loop
First := First + 1;
end loop;
exit when First > Name_Len;
Last := First;
while Last < Name_Len
and then Name_Buffer (Last + 1) /= Path_Separator
loop
Last := Last + 1;
end loop;
if Name_Buffer (First .. Last) = No_Project_Default_Dir then
Add_Default_Dir := False;
for J in Last + 1 .. Name_Len loop
Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
Name_Buffer (J);
end loop;
Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
end if;
First := Last + 1;
end loop;
end if;
if Add_Default_Dir then
Current_Project_Path :=
new String'(Name_Buffer (1 .. Name_Len) & Path_Separator &
Sdefault.Search_Dir_Prefix.all & ".." &
Directory_Separator & ".." & Directory_Separator &
".." & Directory_Separator & "gnat");
else
Current_Project_Path := new String'(Name_Buffer (1 .. Name_Len));
end if;
end;
end Prj.Ext;