1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2006, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
28 with Namet
; use Namet
;
29 with Output
; use Output
;
30 with Osint
; use Osint
;
35 package body Prj
.Ext
is
37 Gpr_Project_Path
: constant String := "GPR_PROJECT_PATH";
38 Ada_Project_Path
: constant String := "ADA_PROJECT_PATH";
39 -- Name of the env. variables that contain path name(s) of directories
40 -- where project files may reside. GPR_PROJECT_PATH has precedence over
43 Gpr_Prj_Path
: constant String_Access
:= Getenv
(Gpr_Project_Path
);
44 Ada_Prj_Path
: constant String_Access
:= Getenv
(Ada_Project_Path
);
45 -- The path name(s) of directories where project files may reside.
48 No_Project_Default_Dir
: constant String := "-";
50 Current_Project_Path
: String_Access
;
51 -- The project path. Initialized during elaboration of package Contains at
52 -- least the current working directory.
54 package Htable
is new GNAT
.HTable
.Simple_HTable
55 (Header_Num
=> Header_Num
,
57 No_Element
=> No_Name
,
61 -- External references are stored in this hash table, either by procedure
62 -- Add (directly or through a call to function Check) or by function
63 -- Value_Of when an environment variable is found non empty. Value_Of
64 -- first for external reference in this table, before checking the
65 -- environment. Htable is emptied (reset) by procedure Reset.
72 (External_Name
: String;
78 Name_Len
:= Value
'Length;
79 Name_Buffer
(1 .. Name_Len
) := Value
;
80 The_Value
:= Name_Find
;
81 Name_Len
:= External_Name
'Length;
82 Name_Buffer
(1 .. Name_Len
) := External_Name
;
83 Canonical_Case_File_Name
(Name_Buffer
(1 .. Name_Len
));
85 Htable
.Set
(The_Key
, The_Value
);
92 function Check
(Declaration
: String) return Boolean is
94 for Equal_Pos
in Declaration
'Range loop
95 if Declaration
(Equal_Pos
) = '=' then
96 exit when Equal_Pos
= Declaration
'First;
97 exit when Equal_Pos
= Declaration
'Last;
100 Declaration
(Declaration
'First .. Equal_Pos
- 1),
102 Declaration
(Equal_Pos
+ 1 .. Declaration
'Last));
114 function Project_Path
return String is
116 return Current_Project_Path
.all;
128 ----------------------
129 -- Set_Project_Path --
130 ----------------------
132 procedure Set_Project_Path
(New_Path
: String) is
134 Free
(Current_Project_Path
);
135 Current_Project_Path
:= new String'(New_Path);
136 end Set_Project_Path;
143 (External_Name : Name_Id;
144 With_Default : Name_Id := No_Name)
148 Name : String := Get_Name_String (External_Name);
151 Canonical_Case_File_Name (Name);
152 Name_Len := Name'Length;
153 Name_Buffer (1 .. Name_Len) := Name;
154 The_Value := Htable.Get (Name_Find);
156 if The_Value /= No_Name then
160 -- Find if it is an environment, if it is, put value in the hash table
163 Env_Value : String_Access := Getenv (Name);
166 if Env_Value /= null and then Env_Value'Length > 0 then
167 Name_Len := Env_Value'Length;
168 Name_Buffer (1 .. Name_Len) := Env_Value.all;
169 The_Value := Name_Find;
170 Htable.Set (External_Name, The_Value);
182 -- Initialize Current_Project_Path during package elaboration
185 Add_Default_Dir : Boolean := True;
190 Prj_Path : String_Access := Gpr_Prj_Path;
193 if Gpr_Prj_Path.all /= "" then
195 -- Warn if both environment variables are defined
197 if Ada_Prj_Path.all /= "" then
198 Write_Line ("Warning: ADA_PROJECT_PATH is not taken into account");
199 Write_Line (" when GPR_PROJECT_PATH is defined");
203 Prj_Path := Ada_Prj_Path;
206 -- The current directory is always first
209 Name_Buffer (Name_Len) := '.';
211 -- If environment variable is defined and not empty, add its content
213 if Prj_Path.all /= "" then
214 Name_Len := Name_Len + 1;
215 Name_Buffer (Name_Len) := Path_Separator;
217 Add_Str_To_Name_Buffer (Prj_Path.all);
219 -- Scan the directory path to see if "-" is one of the directories.
220 -- Remove each occurence of "-" and set Add_Default_Dir to False.
221 -- Also resolve relative paths and symbolic links.
225 while First <= Name_Len
226 and then (Name_Buffer (First) = Path_Separator)
231 exit when First > Name_Len;
235 while Last < Name_Len
236 and then Name_Buffer (Last + 1) /= Path_Separator
241 -- If the directory is "-", set Add_Default_Dir to False and
244 if Name_Buffer (First .. Last) = No_Project_Default_Dir then
245 Add_Default_Dir := False;
247 for J in Last + 1 .. Name_Len loop
248 Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
252 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
254 elsif not Hostparm.OpenVMS
255 or else not Is_Absolute_Path (Name_Buffer (First .. Last))
257 -- On VMS, only expand relative path names, as absolute paths
258 -- may correspond to multi-valued VMS logical names.
261 New_Dir : constant String :=
262 Normalize_Pathname (Name_Buffer (First .. Last));
265 -- If the absolute path was resolved and is different from
266 -- the original, replace original with the resolved path.
268 if New_Dir /= Name_Buffer (First .. Last)
269 and then New_Dir'Length /= 0
271 New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
272 New_Last := First + New_Dir'Length - 1;
273 Name_Buffer (New_Last + 1 .. New_Len) :=
274 Name_Buffer (Last + 1 .. Name_Len);
275 Name_Buffer (First .. New_Last) := New_Dir;
286 -- Set the initial value of Current_Project_Path
288 if Add_Default_Dir then
289 Current_Project_Path :=
290 new String'(Name_Buffer
(1 .. Name_Len
) & Path_Separator
&
291 Sdefault
.Search_Dir_Prefix
.all & ".." &
292 Directory_Separator
& ".." & Directory_Separator
&
293 ".." & Directory_Separator
& "gnat");
295 Current_Project_Path
:= new String'(Name_Buffer (1 .. Name_Len));