------------------------------------------------------------------------------
-- --
-- GPR PROJECT MANAGER --
-- --
-- Copyright (C) 2006-2021, Free Software Foundation, Inc. --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
------------------------------------------------------------------------------
with Ada.Unchecked_Deallocation;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Containers.Indefinite_Hashed_Maps; use Ada.Containers;
with Ada.Strings.Hash;
with Ada.Directories; use Ada.Directories;
with Ada.Environment_Variables; use Ada.Environment_Variables;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.IO_Exceptions;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Hash_Case_Insensitive;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Expect; use GNAT.Expect;
with GNAT.Regpat; use GNAT.Regpat;
with GNAT.Strings; use GNAT.Strings;
with DOM.Core.Documents; use DOM.Core;
with DOM.Core.Nodes; use DOM.Core.Nodes;
with Input_Sources.File; use Input_Sources.File;
with Sax.Readers; use Sax.Readers;
with Schema.Dom_Readers; use Schema.Dom_Readers;
with Schema.Schema_Readers; use Schema.Schema_Readers;
with Schema.Validators; use Schema.Validators;
with GPR.Sdefault; use GPR.Sdefault;
with GPR.Names; use GPR.Names;
with GPR.Opt;
with GPR.Util; use GPR.Util;
package body GPR.Knowledge is
package Known_Languages renames Variables_Maps;
Languages_Known : Known_Languages.Map;
-- Contains all the languages that are described in the database with a
-- real compiler.
package String_Maps is new Ada.Containers.Indefinite_Hashed_Maps
(String, Unbounded_String, Ada.Strings.Hash_Case_Insensitive, "=");
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Pattern_Matcher, Pattern_Matcher_Access);
type External_Value_Item is record
Value : Name_Id;
Alternate : Name_Id := No_Name;
Extracted_From : Name_Id;
end record;
-- Value is the actual value of the node.
-- Extracted_From will either be set to Value itself, or when the node is
-- a to the full directory, before the regexp match.
-- When the value comes from a node, Extracted_From is set to the
-- full output of the shell command.
package External_Value_Lists is new Ada.Containers.Doubly_Linked_Lists
(External_Value_Item);
package String_To_External_Value is new
Ada.Containers.Indefinite_Hashed_Maps
(Key_Type => String,
Element_Type => External_Value_Lists.Cursor,
Hash => Ada.Strings.Hash,
Equivalent_Keys => "=",
"=" => External_Value_Lists."=");
External_Calls_Cache : String_Maps.Map := String_Maps.Empty_Map;
package CDM renames Compiler_Description_Maps;
package CFL renames Compiler_Filter_Lists;
use Compiler_Lists, CFL, Compilers_Filter_Lists;
use Configuration_Lists, String_Maps;
use External_Value_Lists, String_Lists;
use External_Value_Nodes;
Case_Sensitive_Files : constant Boolean := Directory_Separator = '\';
On_Windows : constant Boolean := Directory_Separator = '\';
Ignore_Compiler : exception;
-- Raised when the compiler should be ignored
Indentation_Level : Integer := 0;
-- Current indentation level for traces
function Get_Variable_Value
(Comp : Compiler;
Name : String) return String;
-- Return the value of a predefined or user-defined variable.
-- If the variable is not defined a warning is emitted and an empty
-- string is returned.
procedure Put_Verbose (Config : Configuration);
-- Debug put for Config
function Get_Attribute
(N : Node; Attribute : String; Default : String) return String;
-- Return the value of an attribute, or Default if the attribute does not
-- exist
function Is_Supported_Config
(Base : Knowledge_Base;
Compilers : Compiler_Lists.List) return Boolean;
-- Whether we know how to link code compiled with all the selected
-- compilers.
function Is_Language_With_No_Compiler
(Base : Knowledge_Base;
Language_LC : String) return Boolean;
-- Given a language name (lower case), returns True if that language is
-- known to require no compiler
function Node_Value_As_String (N : Node) return String;
-- Return the value of the node, concatenating all Text children
function Ends_With (Str, Suffix : String) return Boolean;
-- Whether the string ends with Suffix. Always True if Suffix is the empty
-- string.
procedure Foreach_Compiler_In_Dir
(Iterator : in out Compiler_Iterator'Class;
Base : in out Knowledge_Base;
Directory : String;
From_Extra_Dir : Boolean;
On_Target : Targets_Set_Id;
Path_Order : Integer;
Continue : out Boolean);
-- Find all known compilers in Directory, and call Iterator.Callback as
-- appropriate.
procedure Get_Words
(Words : String;
Filter : Name_Id;
Separator1 : Character;
Separator2 : Character;
Map : out String_Lists.List;
Allow_Empty_Elements : Boolean);
-- Return the list of words in Words. Splitting is done on special
-- characters, so as to be compatible with a list of languages or a list of
-- runtimes
-- If Allow_Empty_Elements is false, then empty strings are not stored in
-- the list.
function Name_As_Directory (Dir : String) return String;
-- Ensure that Dir ends with a directory separator
function Get_String_No_Adalib (Str : String) return Name_Id;
-- Return the name without "adalib" at the end
function Get_String (Str : String) return Name_Id;
function Get_String_Or_No_Name (Str : String) return Name_Id;
-- Same as Name_Find, but does not require the user to modify
-- Name_Buffer manually.
-- The second version returns No_Name is the string is empty
procedure Get_External_Value
(Attribute : String;
Value : External_Value;
Comp : Compiler;
Split_Into_Words : Boolean := True;
Merge_Same_Dirs : Boolean := False;
Processed_Value : out External_Value_Lists.List);
-- Computes the value of Value, depending on its type. When an external
-- command needs to be executed, Path is put first on the PATH environment
-- variable.
-- Raises Ignore_Compiler if the value doesn't match its
-- regexp.
-- The node is also taken into account.
-- If Split_Into_Words is true, then the value read from or as a
-- constant string is further assumed to be a comma-separated or space-
-- separated string, and split.
-- Comparisong with Matching is case-insensitive (this is needed for
-- languages, does not matter for versions, is not used for targets)
--
-- If Merge_Same_Dirs is True, then the values that come from a
-- node will be merged (the last one is kept, other removed) if
-- they point to the same physical directory (after normalizing names).
--
-- This is only for use within a context.
procedure Foreach_Language_Runtime
(Iterator : in out Compiler_Iterator'Class;
Base : in out Knowledge_Base;
Name : Name_Id;
Executable : Name_Id;
Directory : String;
Prefix : Name_Id;
From_Extra_Dir : Boolean;
On_Target : Targets_Set_Id;
Descr : Compiler_Description;
Path_Order : Integer;
Continue : out Boolean);
-- For each language/runtime parsed in Languages/Runtimes, create a new
-- compiler in the list, if it matches Matching.
-- If Stop_At_First_Match is true, then only the first matching compiler is
-- returned, which provides a significant speedup in some cases
function Is_Windows_Executable (Filename : String) return Boolean;
-- Verify that a given filename is indeed an executable
procedure Parse_All_Dirs
(Processed_Value : out External_Value_Lists.List;
Visited : in out String_To_External_Value.Map;
Current_Dir : String;
Path_To_Check : String;
Regexp : Pattern_Matcher;
Regexp_Str : String;
Value_If_Match : Name_Id;
Group : Integer;
Group_Match : String := "";
Group_Count : Natural := 0;
Contents : Pattern_Matcher_Access := null;
Merge_Same_Dirs : Boolean);
-- Parse all subdirectories of Current_Dir for those that match
-- Path_To_Check (see description of ). When a match is found,
-- the regexp is evaluated against the current directory, and the matching
-- parenthesis group is appended to Append_To (comma-separated).
-- If Group is -1, then Value_If_Match is used instead of the parenthesis
-- group.
-- Group_Match is the substring that matched Group (if it has been matched
-- already). Group_Count is the number of parenthesis groups that have been
-- processed so far. The idea is to compute the matching substring as we
-- go, since the regexp might no longer match in the end, if for instance
-- it includes ".." directories.
--
-- If Merge_Same_Dirs is True, then the values that come from a
-- node will be merged (the last one is kept, other removed) if
-- they point to the same physical directory (after normalizing names). In
-- this case, Visited contains the list of normalized directory names.
--
-- Contents, if specified, is a regular expression. It indicates that any
-- file matching the pattern should be parsed, and the first line matching
-- that regexp should be used as the name of the file instead. This is a
-- way to simulate symbolic links on platforms that do not use them.
generic
with function Callback (Var_Name, Index : String) return String;
function Substitute_Variables (Str : String) return String;
-- Substitute variables in Str (their value is computed through Callback)
function Substitute_Variables_In_Compiler_Description
(Str : String; Comp : Compiler) return String;
function Substitute_Variables_In_Configuration
(Base : Knowledge_Base;
Str : String;
Comps : Compiler_Lists.List) return String;
-- Substitute the special "$..." names.
-- Depending on the XML nodes we are in (specified by the context) the list
-- of variables might be different.
procedure Match
(Filter : Compilers_Filter_Lists.List;
Compilers : Compiler_Lists.List;
Matching_Compiler : out Compiler_Access;
Matched : out Boolean);
procedure Match
(Filter : Compilers_Filter;
Compilers : Compiler_Lists.List;
Matching_Compiler : out Compiler_Access;
Matched : out Boolean);
procedure Match
(Filter : Compiler_Filter;
Compilers : Compiler_Lists.List;
Matching_Compiler : out Compiler_Access;
Matched : out Boolean);
-- Check whether Filter matches (and set Matched to the result).
-- Matching_Compiler is set if there was a single node, and is
-- to set the first compiler that matched in that node
function Match
(Target_Filter : Double_String_Lists.List;
Negate : Boolean;
Compilers : Compiler_Lists.List) return Boolean;
-- Return True if Filter matches the list of selected configurations
procedure Merge_Config
(Base : Knowledge_Base;
Packages : in out String_Maps.Map;
Compilers : Compiler_Lists.List;
Config : String);
-- Merge the contents of Config into Packages, so that each attributes ends
-- up in the right package, and the packages are not duplicated.
-- Selected_Compiler is the compiler that made the chunk match the filters.
-- If there were several filter, No_Compiler should be passed
-- in argument.
procedure Skip_Spaces (Str : String; Index : in out Integer);
-- Move Index from its current position to the next non-whitespace
-- character in Str
procedure Skip_Spaces_Backward (Str : String; Index : in out Integer);
-- Same as Skip_Spaces, but goes backward
function Is_Regexp (Str : String) return Boolean;
-- Whether Str is a regular expression
Exec_Suffix : constant GNAT.Strings.String_Access :=
Get_Executable_Suffix;
function Unquote
(Str : String; Remove_Quoted : Boolean := False) return String;
-- Remove special '\' quoting characters from Str.
-- As a special case, if Remove_Quoted is true, then '\' and the following
-- char are simply omitted in the output.
-- For instance:
-- Str="A\." Remove_Quoted=False => output is "A."
-- Str="A\." Remove_Quoted=False => output is "A"
procedure Free (Descr : in out Compiler_Description);
procedure Free (Config : in out Configuration);
procedure Free (TSD : in out Target_Set_Description);
procedure Free (Ext_Val : in out External_Value_Node);
-------------------
-- Get_Attribute --
-------------------
function Get_Attribute
(N : Node; Attribute : String; Default : String) return String
is
Attr : constant Node := Get_Named_Item (Attributes (N), Attribute);
begin
if Attr = null then
return Default;
else
return Node_Value (Attr);
end if;
end Get_Attribute;
--------------------------
-- Node_Value_As_String --
--------------------------
function Node_Value_As_String (N : Node) return String is
Result : Unbounded_String;
Child : Node := First_Child (N);
begin
while Child /= null loop
exit when Node_Type (Child) = Element_Node;
Append (Result, Node_Value (Child));
Child := Next_Sibling (Child);
end loop;
return To_String (Result);
end Node_Value_As_String;
-------------
-- Unquote --
-------------
function Unquote
(Str : String; Remove_Quoted : Boolean := False) return String
is
Str2 : String (Str'Range);
S : Integer := Str'First;
Index : Integer := Str2'First;
begin
while S <= Str'Last loop
if Str (S) = '\' then
S := S + 1;
if not Remove_Quoted then
Str2 (Index) := Str (S);
Index := Index + 1;
end if;
else
Str2 (Index) := Str (S);
Index := Index + 1;
end if;
S := S + 1;
end loop;
return Str2 (Str2'First .. Index - 1);
end Unquote;
---------------
-- Ends_With --
---------------
function Ends_With (Str, Suffix : String) return Boolean is
begin
return Suffix = ""
or else
(Str'Length >= Suffix'Length
and then Str (Str'Last - Suffix'Length + 1 .. Str'Last) = Suffix);
end Ends_With;
---------------------------
-- Is_Windows_Executable --
---------------------------
function Is_Windows_Executable (Filename : String) return Boolean is
type Byte is mod 256;
for Byte'Size use 8;
for Byte'Alignment use 1;
type Bytes is array (Positive range <>) of Byte;
Windows_Pattern : constant Bytes := (77, 90, 144, 0);
Fd : constant File_Descriptor := Open_Read (Filename, Binary);
B : Bytes (1 .. 4);
N_Read : Integer;
begin
N_Read := Read (Fd, B'Address, 4);
Close (Fd);
if N_Read < 4 then
return False;
else
if B = Windows_Pattern then
return True;
else
return False;
end if;
end if;
end Is_Windows_Executable;
---------------
-- Is_Regexp --
---------------
function Is_Regexp (Str : String) return Boolean is
-- Take into account characters quoted by '\'. We just remove them for
-- now, so that when we quote the regexp it won't see these potentially
-- special characters.
-- The goal is that for instance "\.\." is not considered as a regexp,
-- but "\.." is.
Str2 : constant String := Unquote (Str, Remove_Quoted => True);
begin
return GNAT.Regpat.Quote (Str2) /= Str2;
end Is_Regexp;
-----------------
-- Put_Verbose --
-----------------
procedure Put_Verbose (Str : String; Indent_Delta : Integer := 0) is
begin
if Current_Verbosity /= Default then
if Indent_Delta < 0 then
Indentation_Level := Indentation_Level - 2;
end if;
if Str /= "" then
Put_Line (Standard_Error, (1 .. Indentation_Level => ' ') & Str);
end if;
if Indent_Delta > 0 then
Indentation_Level := Indentation_Level + 2;
end if;
end if;
end Put_Verbose;
-----------------------
-- Name_As_Directory --
-----------------------
function Name_As_Directory (Dir : String) return String is
begin
if Dir = ""
or else Dir (Dir'Last) = Directory_Separator
or else Dir (Dir'Last) = '/'
then
return Dir;
else
return Dir & Directory_Separator;
end if;
end Name_As_Directory;
----------------------------------
-- Is_Language_With_No_Compiler --
----------------------------------
function Is_Language_With_No_Compiler
(Base : Knowledge_Base;
Language_LC : String) return Boolean
is
C : String_Lists.Cursor := First (Base.No_Compilers);
begin
while Has_Element (C) loop
if String_Lists.Element (C) = Language_LC then
return True;
end if;
Next (C);
end loop;
return False;
end Is_Language_With_No_Compiler;
RTS_List : GNAT.OS_Lib.String_List_Access :=
new GNAT.OS_Lib.String_List (1 .. 4);
-- List of the knowledge base directories that have already been parsed
RTS_Last : Natural := 0;
-- Index of the last directory in RTS_List
--------------------------
-- Parse_Knowledge_Base --
--------------------------
procedure Parse_Knowledge_Base
(Base : in out Knowledge_Base;
Directory : String;
Parse_Compiler_Info : Boolean := True;
Validate : Boolean := False)
is
procedure Parse_Compiler_Description
(Base : in out Knowledge_Base;
File : String;
Description : Node);
-- Parse a compiler description described by N. Appends the result to
-- Base.Compilers or Base.No_Compilers
procedure Parse_Configuration
(Append_To : in out Configuration_Lists.List;
File : String;
Description : Node);
-- Parse a configuration node
procedure Parse_Targets_Set
(Append_To : in out Targets_Set_Vectors.Vector;
File : String;
Description : Node);
-- Parse a targets set node
procedure Parse_Fallback_Targets_Set
(Append_To : in out Fallback_Targets_Set_Vectors.Vector;
File : String;
Description : Node);
-- Parse a fallback_targets set node
--------------------------------
-- Parse_Compiler_Description --
--------------------------------
procedure Parse_Compiler_Description
(Base : in out Knowledge_Base;
File : String;
Description : Node)
is
procedure Parse_External_Value
(Value : out External_Value;
File : String;
External : Node);
-- Parse an XML node that describes an external value
--------------------------
-- Parse_External_Value --
--------------------------
procedure Parse_External_Value
(Value : out External_Value;
File : String;
External : Node)
is
Tmp : Node := First_Child (External);
External_Node : External_Value_Node;
Is_Done : Boolean := True;
Static_Value : constant String := Node_Value_As_String (External);
Has_Static : Boolean := False;
begin
for S in Static_Value'Range loop
if Static_Value (S) /= ' '
and then Static_Value (S) /= ASCII.LF
then
Has_Static := True;
exit;
end if;
end loop;
-- Constant value is not within a nested node
if Has_Static then
External_Node :=
(Typ => Value_Constant,
Value => Get_String (Static_Value));
Append (Value, External_Node);
Is_Done := False;
end if;
while Tmp /= null loop
if Node_Type (Tmp) /= Element_Node then
null;
elsif Node_Name (Tmp) = "external" then
if not Is_Done then
Append (Value, (Typ => Value_Done));
end if;
External_Node :=
(Typ => Value_Shell,
Command => Get_String (Node_Value_As_String (Tmp)));
Append (Value, External_Node);
Is_Done := False;
elsif Node_Name (Tmp) = "directory" then
declare
C : constant String :=
Get_Attribute (Tmp, "contents", "");
Contents : Pattern_Matcher_Access;
begin
if C /= "" then
Contents := new Pattern_Matcher'(Compile (C));
end if;
External_Node :=
(Typ => Value_Directory,
Directory => Get_String
(Node_Value_As_String (Tmp)),
Contents => Contents,
Dir_If_Match => No_Name,
Directory_Group => 0);
end;
begin
External_Node.Directory_Group := Integer'Value
(Get_Attribute (Tmp, "group", "0"));
exception
when Constraint_Error =>
External_Node.Directory_Group := -1;
External_Node.Dir_If_Match :=
Get_String (Get_Attribute (Tmp, "group", "0"));
end;
Append (Value, External_Node);
Is_Done := True;
elsif Node_Name (Tmp) = "getenv" then
if not Is_Done then
Append (Value, (Typ => Value_Done));
end if;
declare
Name : constant String := Get_Attribute (Tmp, "name", "");
begin
if Ada.Environment_Variables.Exists (Name) then
External_Node :=
(Typ => Value_Constant,
Value => Get_String
(Ada.Environment_Variables.Value (Name)));
else
Put_Verbose ("warning: environment variable '" & Name
& "' is not defined");
External_Node :=
(Typ => Value_Constant,
Value => No_Name);
end if;
end;
Append (Value, External_Node);
Is_Done := False;
elsif Node_Name (Tmp) = "filter" then
External_Node :=
(Typ => Value_Filter,
Filter => Get_String (Node_Value_As_String (Tmp)));
Append (Value, External_Node);
Is_Done := True;
elsif Node_Name (Tmp) = "must_match" then
External_Node :=
(Typ => Value_Must_Match,
Must_Match => Get_String (Node_Value_As_String (Tmp)));
Append (Value, External_Node);
Is_Done := True;
elsif Node_Name (Tmp) = "grep" then
External_Node :=
(Typ => Value_Grep,
Regexp_Re => new Pattern_Matcher'
(Compile (Get_Attribute (Tmp, "regexp", ".*"),
Multiple_Lines)),
Group => Integer'Value
(Get_Attribute (Tmp, "group", "0")));
Append (Value, External_Node);
elsif Node_Name (Tmp) = "nogrep" then
External_Node :=
(Typ => Value_Nogrep,
Regexp_No => new Pattern_Matcher'
(Compile (Get_Attribute (Tmp, "regexp", ".*"),
Multiple_Lines)));
Append (Value, External_Node);
else
Put_Line (Standard_Error, "Invalid XML description for "
& Node_Name (External) & " in file " & File);
Put_Line
(Standard_Error, " Invalid tag: " & Node_Name (Tmp));
Value := Null_External_Value;
end if;
Tmp := Next_Sibling (Tmp);
end loop;
if not Is_Done then
Append (Value, (Typ => Value_Done));
end if;
exception
when Constraint_Error =>
Put_Line (Standard_Error, "Invalid group number for "
& Node_Name (External)
& " in file " & File);
Value := Null_External_Value;
end Parse_External_Value;
Compiler : Compiler_Description;
N : Node := First_Child (Description);
Lang : External_Value_Lists.List;
C : External_Value_Lists.Cursor;
begin
while N /= null loop
if Node_Type (N) /= Element_Node then
null;
elsif Node_Name (N) = "executable" then
declare
Prefix : constant String :=
Get_Attribute (N, "prefix", "@@");
Val : constant String := Node_Value_As_String (N);
begin
if Val = "" then
-- A special language that requires no executable. We do
-- not store it in the list of compilers, since these
-- should not be detected on the PATH anyway.
Compiler.Executable := No_Name;
else
Compiler.Executable := Get_String (Val);
begin
Compiler.Prefix_Index := Integer'Value (Prefix);
exception
when Constraint_Error =>
Compiler.Prefix_Index := -1;
end;
if not Ends_With (Val, Exec_Suffix.all) then
Compiler.Executable_Re := new Pattern_Matcher'
(Compile ("^" & Val & Exec_Suffix.all & "$"));
else
Compiler.Executable_Re := new Pattern_Matcher'
(Compile ("^" & Val & "$"));
end if;
Base.Check_Executable_Regexp := True;
end if;
exception
when Expression_Error =>
Put_Line
(Standard_Error,
"Invalid regular expression found in the configuration"
& " files: " & Val
& " while parsing " & File);
Unchecked_Free (Compiler.Executable_Re);
end;
elsif Node_Name (N) = "name" then
Compiler.Name := Get_String (Node_Value_As_String (N));
elsif Node_Name (N) = "version" then
Parse_External_Value
(Value => Compiler.Version,
File => File,
External => N);
elsif Node_Name (N) = "variable" then
declare
Name : constant String := Get_Attribute (N, "name", "@@");
begin
Append (Compiler.Variables, (Typ => Value_Variable,
Var_Name => Get_String (Name)));
Parse_External_Value
(Value => Compiler.Variables,
File => File,
External => N);
end;
elsif Node_Name (N) = "languages" then
Parse_External_Value
(Value => Compiler.Languages,
File => File,
External => N);
elsif Node_Name (N) = "runtimes" then
declare
Defaults : constant String :=
Get_Attribute (N, "default", "");
begin
if Defaults /= "" then
Get_Words (Defaults, No_Name, ' ', ',',
Compiler.Default_Runtimes, False);
end if;
Parse_External_Value
(Value => Compiler.Runtimes,
File => File,
External => N);
end;
elsif Node_Name (N) = "target" then
Parse_External_Value
(Value => Compiler.Target,
File => File,
External => N);
else
Put_Line
(Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N));
raise Invalid_Knowledge_Base;
end if;
N := Next_Sibling (N);
end loop;
if Compiler.Executable = No_Name then
Get_External_Value
(Attribute => "languages",
Value => Compiler.Languages,
Comp => No_Compiler,
Split_Into_Words => True,
Processed_Value => Lang);
C := First (Lang);
while Has_Element (C) loop
String_Lists.Append
(Base.No_Compilers,
To_Lower
(Get_Name_String
(External_Value_Lists.Element (C).Value)));
Next (C);
end loop;
elsif Compiler.Name /= No_Name then
CDM.Include (Base.Compilers, Compiler.Name, Compiler);
-- Include the language name in the Languages_Known hashed map,
-- if it is not already there.
Get_External_Value
(Attribute => "languages",
Value => Compiler.Languages,
Comp => No_Compiler,
Split_Into_Words => True,
Processed_Value => Lang);
C := First (Lang);
while Has_Element (C) loop
declare
Lang_Name : constant Name_Id :=
Get_Lower_Name_Id
(Get_Name_String
(External_Value_Lists.Element (C).Value));
Position : Known_Languages.Cursor;
Inserted : Boolean;
begin
Languages_Known.Insert
(Key => Lang_Name,
New_Item => Lang_Name,
Position => Position,
Inserted => Inserted);
end;
Next (C);
end loop;
end if;
end Parse_Compiler_Description;
-------------------------
-- Parse_Configuration --
-------------------------
procedure Parse_Configuration
(Append_To : in out Configuration_Lists.List;
File : String;
Description : Node)
is
Config : Configuration;
Chunk : Unbounded_String;
N : Node := First_Child (Description);
N2 : Node;
Compilers : Compilers_Filter;
Ignore_Config : Boolean := False;
Negate : Boolean;
Filter : Compiler_Filter;
function Compile_And_Check (Name : String) return Pattern_Matcher;
-- Compile pattern and report illegal regexp if needed.
function Compile_And_Check (Name : String) return Pattern_Matcher
is
begin
return Compile (Name, GNAT.Regpat.Case_Insensitive);
exception
when Expression_Error =>
Put_Line
(Standard_Error,
"gprconfig: invalid regexp '"
& Name & "' in " & File
& "; corresponding configuration "
& "node skipped");
raise;
end Compile_And_Check;
begin
Config.Supported := True;
while N /= null loop
if Node_Type (N) /= Element_Node then
null;
elsif Node_Name (N) = "compilers" then
Compilers := No_Compilers_Filter;
N2 := First_Child (N);
while N2 /= null loop
if Node_Type (N2) /= Element_Node then
null;
elsif Node_Name (N2) = "compiler" then
declare
Name : constant String :=
Get_Attribute (N2, "name", "");
Version : constant String :=
Get_Attribute (N2, "version", "");
Runtime : constant String :=
Get_Attribute (N2, "runtime", "");
begin
Filter := Compiler_Filter'
(Name => Get_String_Or_No_Name (Name),
Name_Re => null,
Version => Get_String_Or_No_Name (Version),
Version_Re => null,
Runtime => Get_String_Or_No_Name (Runtime),
Runtime_Re => null,
Language_LC => Get_String_Or_No_Name
(To_Lower (Get_Attribute (N2, "language", ""))));
-- We do not want to invalidate the whole Knowledge
-- Base because of a wrong regexp. Istead, report it
-- and skip corresponding node.
if Name /= "" then
Filter.Name_Re := new Pattern_Matcher'
(Compile_And_Check (Name));
end if;
if Version /= "" then
Filter.Version_Re := new Pattern_Matcher'
(Compile_And_Check (Version));
end if;
if Runtime /= "" then
Filter.Runtime_Re := new Pattern_Matcher'
(Compile_And_Check (Runtime));
end if;
end;
Append (Compilers.Compiler, Filter);
else
Put_Line
(Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N2));
raise Invalid_Knowledge_Base;
end if;
N2 := Next_Sibling (N2);
end loop;
Compilers.Negate := Boolean'Value
(Get_Attribute (N, "negate", "False"));
Append (Config.Compilers_Filters, Compilers);
elsif Node_Name (N) = "targets" then
if not Is_Empty (Config.Targets_Filters) then
Put_Line (Standard_Error,
"Can have a single filter in " & File);
else
N2 := First_Child (N);
while N2 /= null loop
if Node_Type (N2) /= Element_Node then
null;
elsif Node_Name (N2) = "target" then
declare
Double_Regexp : Double_String;
begin
Double_Regexp.Positive_Regexp :=
To_Unbounded_String
(Get_Attribute (N2, "name", ""));
Double_Regexp.Negative_Regexp :=
To_Unbounded_String
(Get_Attribute (N2, "except", ""));
Append (Config.Targets_Filters, Double_Regexp);
end;
else
Put_Line
(Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N2));
raise Invalid_Knowledge_Base;
end if;
N2 := Next_Sibling (N2);
end loop;
Config.Negate_Targets := Boolean'Value
(Get_Attribute (N, "negate", "False"));
end if;
elsif Node_Name (N) = "hosts" then
-- Resolve this filter immediately. This saves memory, since we
-- don't need to store it in memory if we know it won't apply.
N2 := First_Child (N);
Negate := Boolean'Value
(Get_Attribute (N, "negate", "False"));
Ignore_Config := not Negate;
while N2 /= null loop
if Node_Type (N2) /= Element_Node then
null;
elsif Node_Name (N2) = "host" then
if Match
(Get_Attribute (N2, "name", ""), Sdefault.Hostname)
and then
(Get_Attribute (N2, "except", "") = ""
or else not Match
(Get_Attribute (N2, "except", ""),
Sdefault.Hostname))
then
Ignore_Config := Negate;
exit;
end if;
else
Put_Line
(Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N2));
raise Invalid_Knowledge_Base;
end if;
N2 := Next_Sibling (N2);
end loop;
exit when Ignore_Config;
elsif Node_Name (N) = "config" then
if Node_Value_As_String (N) = "" then
Config.Supported := False;
else
Append (Chunk, Node_Value_As_String (N));
end if;
else
Put_Line (Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N));
raise Invalid_Knowledge_Base;
end if;
N := Next_Sibling (N);
end loop;
if not Ignore_Config then
Config.Config := Get_String (To_String (Chunk));
Append (Append_To, Config);
end if;
exception
when Expression_Error =>
null;
-- Proper warning message has been already emitted, so we just
-- skip corresponding configuration node.
end Parse_Configuration;
--------------------------------
-- Parse_Fallback_Targets_Set --
--------------------------------
procedure Parse_Fallback_Targets_Set
(Append_To : in out Fallback_Targets_Set_Vectors.Vector;
File : String;
Description : Node)
is
Set : String_Lists.List;
N : Node := First_Child (Description);
begin
while N /= null loop
if Node_Type (N) /= Element_Node then
null;
elsif Node_Name (N) = "target" then
String_Lists.Append (Set, Node_Value_As_String (N));
else
Put_Line (Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N));
raise Invalid_Knowledge_Base;
end if;
N := Next_Sibling (N);
end loop;
if not String_Lists.Is_Empty (Set) then
Fallback_Targets_Set_Vectors.Append (Append_To, Set);
end if;
end Parse_Fallback_Targets_Set;
-----------------------
-- Parse_Targets_Set --
-----------------------
procedure Parse_Targets_Set
(Append_To : in out Targets_Set_Vectors.Vector;
File : String;
Description : Node)
is
Name : Name_Id := No_Name;
Set : Target_Lists.List;
Pattern : Pattern_Matcher_Access;
N : Node := First_Child (Description);
Canon : constant String :=
Get_Attribute (Description, "canonical", "");
begin
if Canon = "" then
if Pedantic_KB then
Put_Line
("No canonical target specified for target-set in "
& Node_Name (N) & " in "
& File);
raise Invalid_Knowledge_Base;
end if;
else
Name := Get_String (Canon);
end if;
while N /= null loop
if Node_Type (N) /= Element_Node then
null;
elsif Node_Name (N) = "target" then
declare
Val : constant String := Node_Value_As_String (N);
begin
Pattern := new Pattern_Matcher'(Compile ("^" & Val & "$"));
Target_Lists.Append (Set, Pattern);
if Name = No_Name then
-- When not in pedantic mode and working with
-- an old KB the first target in the target set
-- is taken as canonical target.
Name := Get_String (Val);
end if;
exception
when Expression_Error =>
Put_Line
("Invalid regular expression " & Val
& " found in the target-set while parsing " & File);
raise Invalid_Knowledge_Base;
end;
else
Put_Line (Standard_Error, "Unknown XML tag in " & File & ": "
& Node_Name (N));
raise Invalid_Knowledge_Base;
end if;
N := Next_Sibling (N);
end loop;
if not Target_Lists.Is_Empty (Set) then
Targets_Set_Vectors.Append (Append_To, (Name, Set), 1);
end if;
end Parse_Targets_Set;
Search : Search_Type;
File : Directory_Entry_Type;
File_Node : Node;
N : Node;
Reader : Schema.Dom_Readers.Tree_Reader;
Input : File_Input;
Schema : Schema_Reader;
In_Files : String_Sets.Set;
Cur : String_Sets.Cursor;
Shortname : GNAT.Strings.String_Access;
Dir : constant String :=
Normalize_Pathname (Directory, Case_Sensitive => False);
use String_Sets;
begin
-- Do not parse several times the same database directory
for J in 1 .. RTS_Last loop
if RTS_List (J).all = Dir then
return;
end if;
end loop;
-- Extend RTS_List if it is full
if RTS_Last = RTS_List'Last then
declare
New_List : constant GNAT.OS_Lib.String_List_Access :=
new GNAT.OS_Lib.String_List (1 .. RTS_List'Length * 2);
begin
New_List (1 .. RTS_Last) := RTS_List (1 .. RTS_Last);
RTS_List := New_List;
end;
end if;
RTS_Last := RTS_Last + 1;
RTS_List (RTS_Last) := new String'(Dir);
Reader.Set_Feature (Schema_Validation_Feature, Validate);
Reader.Set_Feature (Validation_Feature, False); -- Do not use DTD
if Validate then
-- Load the XSD file used to validate the knowledge base
declare
Filename : constant String :=
Format_Pathname
(Default_Knowledge_Base_Directory
& "/gprconfig.xsd");
XSD : File_Input;
begin
Put_Verbose ("Parsing " & Filename);
Open (Filename, XSD);
Parse (Schema, XSD);
Close (XSD);
Reader.Set_Grammar (Get_Grammar (Schema));
Free (Schema);
exception
when Ada.Directories.Name_Error =>
Put_Line
(Standard_Error,
"Installation error: could not find the file " & Filename);
raise Knowledge_Base_Validation_Error;
when XML_Validation_Error =>
Put_Line (Standard_Error, Get_Error_Message (Schema));
raise Knowledge_Base_Validation_Error;
end;
end if;
Put_Verbose ("Parsing knowledge base at " & Dir);
Start_Search
(Search,
Directory => Dir,
Pattern => "*.xml",
Filter => (Ordinary_File => True, others => False));
while More_Entries (Search) loop
Get_Next_Entry (Search, File);
In_Files.Include (Full_Name (File));
end loop;
End_Search (Search);
Cur := In_Files.First;
while Cur /= String_Sets.No_Element loop
Shortname := new String'
(GNAT.Directory_Operations.Base_Name (String_Sets.Element (Cur)));
Put_Verbose ("Parsing file " & String_Sets.Element (Cur));
Open (String_Sets.Element (Cur), Input);
Parse (Reader, Input);
Close (Input);
File_Node := DOM.Core.Documents.Get_Element (Get_Tree (Reader));
if Node_Name (File_Node) = "gprconfig" then
N := First_Child (File_Node);
while N /= null loop
if Node_Type (N) /= Element_Node then
null;
elsif Node_Name (N) = "compiler_description" then
if Parse_Compiler_Info then
Parse_Compiler_Description
(Base => Base,
File => Shortname.all,
Description => N);
end if;
elsif Node_Name (N) = "configuration" then
if Parse_Compiler_Info then
Parse_Configuration
(Append_To => Base.Configurations,
File => Shortname.all,
Description => N);
end if;
elsif Node_Name (N) = "targetset" then
Parse_Targets_Set
(Append_To => Base.Targets_Sets,
File => Shortname.all,
Description => N);
elsif Node_Name (N) = "fallback_targets" then
Parse_Fallback_Targets_Set
(Append_To => Base.Fallback_Targets_Sets,
File => Shortname.all,
Description => N);
else
Put_Line (Standard_Error,
"Unknown XML tag in "
& Shortname.all & ": "
& Node_Name (N));
raise Invalid_Knowledge_Base;
end if;
N := Next_Sibling (N);
end loop;
else
Put_Line (Standard_Error,
"Invalid toplevel XML tag in "
& Shortname.all);
end if;
declare
Doc : Document := Get_Tree (Reader);
begin
Free (Doc);
end;
Free (Reader);
GNAT.Strings.Free (Shortname);
Next (Cur);
end loop;
In_Files.Clear;
exception
when Ada.Directories.Name_Error =>
Put_Verbose ("Directory not found: " & Directory);
when Ada.Directories.Use_Error =>
Put_Verbose ("Directory not readable: " & Directory);
when Invalid_Knowledge_Base | Knowledge_Base_Validation_Error =>
raise;
when E : XML_Fatal_Error =>
Put_Line (Standard_Error, Exception_Message (E));
raise Invalid_Knowledge_Base;
when XML_Validation_Error =>
Put_Line (Standard_Error, Get_Error_Message (Reader));
raise Knowledge_Base_Validation_Error;
when E : others =>
Put_Line
(Standard_Error,
"Unexpected exception while parsing knowledge base: "
& Exception_Information (E));
raise Invalid_Knowledge_Base;
end Parse_Knowledge_Base;
-------------------------
-- Free_Knowledge_Base --
-------------------------
procedure Free_Knowledge_Base (Base : in out Knowledge_Base) is
begin
for El of Base.Compilers loop
Free (El);
end loop;
Base.Compilers.Clear;
Base.No_Compilers.Clear;
for El of Base.Configurations loop
Free (El);
end loop;
Base.Configurations.Clear;
for El of Base.Targets_Sets loop
Free (El);
end loop;
Base.Targets_Sets.Clear;
for El of Base.Fallback_Targets_Sets loop
El.Clear;
end loop;
Base.Fallback_Targets_Sets.Clear;
end Free_Knowledge_Base;
------------------------
-- Get_Variable_Value --
------------------------
function Get_Variable_Value
(Comp : Compiler;
Name : String) return String
is
N : constant Name_Id := Get_String (Name);
begin
if Variables_Maps.Contains (Comp.Variables, N) then
return Get_Name_String (Variables_Maps.Element (Comp.Variables, N));
elsif Name = "HOST" then
return Sdefault.Hostname;
elsif Name = "TARGET" then
return Get_Name_String (Comp.Target);
elsif Name = "RUNTIME_DIR" then
return Name_As_Directory (Get_Name_String (Comp.Runtime_Dir));
elsif Name = "EXEC" then
return Get_Name_String_Or_Null (Comp.Executable);
elsif Name = "VERSION" then
return Get_Name_String_Or_Null (Comp.Version);
elsif Name = "LANGUAGE" then
return Get_Name_String_Or_Null (Comp.Language_LC);
elsif Name = "RUNTIME" then
return Get_Name_String_Or_Null (Comp.Runtime);
elsif Name = "PREFIX" then
return Get_Name_String_Or_Null (Comp.Prefix);
elsif Name = "PATH" then
return Get_Name_String (Comp.Path);
elsif Name = "GPRCONFIG_PREFIX" then
return Executable_Prefix_Path;
end if;
raise Invalid_Knowledge_Base
with "variable '" & Name & "' is not defined";
end Get_Variable_Value;
--------------------------
-- Substitute_Variables --
--------------------------
function Substitute_Variables (Str : String) return String is
Str_Len : constant Natural := Str'Last;
Pos : Natural := Str'First;
Last : Natural := Pos;
Result : Unbounded_String;
Word_Start, Word_End, Tmp : Natural;
Has_Index : Boolean;
begin
while Pos < Str_Len loop
if Str (Pos) = '$' and then Str (Pos + 1) = '$' then
Append (Result, Str (Last .. Pos - 1));
Append (Result, "$");
Last := Pos + 2;
Pos := Last;
elsif Str (Pos) = '$' then
if Str (Pos + 1) = '{' then
Word_Start := Pos + 2;
Tmp := Pos + 2;
while Tmp <= Str_Len and then Str (Tmp) /= '}' loop
Tmp := Tmp + 1;
end loop;
Tmp := Tmp + 1;
Word_End := Tmp - 2;
else
Word_Start := Pos + 1;
Tmp := Pos + 1;
while Tmp <= Str_Len
and then (Is_Alphanumeric (Str (Tmp)) or else Str (Tmp) = '_')
loop
Tmp := Tmp + 1;
end loop;
Word_End := Tmp - 1;
end if;
Append (Result, Str (Last .. Pos - 1));
Has_Index := False;
for W in Word_Start .. Word_End loop
if Str (W) = '(' then
Has_Index := True;
if Str (Word_End) /= ')' then
Put_Line
(Standard_Error,
"Missing closing parenthesis in variable name: "
& Str (Word_Start .. Word_End));
raise Invalid_Knowledge_Base;
else
Append
(Result,
Callback
(Var_Name => Str (Word_Start .. W - 1),
Index => Str (W + 1 .. Word_End - 1)));
end if;
exit;
end if;
end loop;
if not Has_Index then
Append (Result, Callback (Str (Word_Start .. Word_End), ""));
end if;
Last := Tmp;
Pos := Last;
else
Pos := Pos + 1;
end if;
end loop;
Append (Result, Str (Last .. Str_Len));
return To_String (Result);
end Substitute_Variables;
--------------------------------------------------
-- Substitute_Variables_In_Compiler_Description --
--------------------------------------------------
function Substitute_Variables_In_Compiler_Description
(Str : String;
Comp : Compiler) return String
is
function Callback (Var_Name, Index : String) return String;
--------------
-- Callback --
--------------
function Callback (Var_Name, Index : String) return String is
begin
if Index /= "" then
Put_Line
(Standard_Error,
"Indexed variables only allowed in (in "
& Var_Name & "(" & Index & ")");
raise Invalid_Knowledge_Base;
end if;
return Get_Variable_Value (Comp, Var_Name);
end Callback;
function Do_Substitute is new Substitute_Variables (Callback);
begin
return Do_Substitute (Str);
end Substitute_Variables_In_Compiler_Description;
-------------------------------------------
-- Substitute_Variables_In_Configuration --
-------------------------------------------
function Substitute_Variables_In_Configuration
(Base : Knowledge_Base;
Str : String;
Comps : Compiler_Lists.List) return String
is
function Callback (Var_Name, Index : String) return String;
--------------
-- Callback --
--------------
function Callback (Var_Name, Index : String) return String is
C : Compiler_Lists.Cursor;
Comp : Compiler_Access;
Idx : constant Name_Id := Get_String_Or_No_Name (To_Lower (Index));
begin
if Var_Name = "GPRCONFIG_PREFIX" then
return Executable_Prefix_Path;
elsif Index = "" then
if Var_Name = "TARGET"
and then not Is_Empty (Comps)
then
-- Can have an optional language index.
-- If there is no index, all compilers share the same target,
-- so just take that of the first compiler in the list
return Normalized_Target
(Base,
Compiler_Lists.Element (First (Comps)).Targets_Set);
else
Put_Line
(Standard_Error,
"Ambiguous variable substitution, need to specify the"
& " language (in " & Var_Name & ")");
raise Invalid_Knowledge_Base;
end if;
else
C := First (Comps);
while Has_Element (C) loop
Comp := Compiler_Lists.Element (C);
if Comp.Selected
and then Comp.Language_LC = Idx
then
return Get_Variable_Value (Comp.all, Var_Name);
end if;
Next (C);
end loop;
end if;
return "";
end Callback;
function Do_Substitute is new Substitute_Variables (Callback);
begin
return Do_Substitute (Str);
end Substitute_Variables_In_Configuration;
--------------------
-- Parse_All_Dirs --
--------------------
procedure Parse_All_Dirs
(Processed_Value : out External_Value_Lists.List;
Visited : in out String_To_External_Value.Map;
Current_Dir : String;
Path_To_Check : String;
Regexp : Pattern_Matcher;
Regexp_Str : String;
Value_If_Match : Name_Id;
Group : Integer;
Group_Match : String := "";
Group_Count : Natural := 0;
Contents : Pattern_Matcher_Access := null;
Merge_Same_Dirs : Boolean)
is
procedure Save_File (Current_Dir : String; Val : Name_Id);
-- Mark the given directory as valid for the configuration.
-- This takes care of removing duplicates if needed.
---------------
-- Save_File --
---------------
procedure Save_File (Current_Dir : String; Val : Name_Id) is
begin
if not Merge_Same_Dirs then
Put_Verbose (": SAVE " & Current_Dir);
Append
(Processed_Value,
(Value => Val,
Alternate => No_Name,
Extracted_From => Get_String_No_Adalib (Current_Dir)));
else
declare
use String_To_External_Value;
Normalized : constant String := Normalize_Pathname
(Name => Current_Dir,
Directory => "",
Resolve_Links => True,
Case_Sensitive => True);
Prev : External_Value_Lists.Cursor;
Rec : External_Value_Item;
begin
if Visited.Contains (Normalized) then
Put_Verbose (": ALREADY FOUND ("
& Get_Name_String (Val) & ") "
& Current_Dir);
Prev := Visited.Element (Normalized);
Rec := External_Value_Lists.Element (Prev);
Rec.Alternate := Val;
External_Value_Lists.Replace_Element
(Container => Processed_Value,
Position => Prev,
New_Item => Rec);
else
Put_Verbose (": SAVE (" & Get_Name_String (Val)
& ") " & Current_Dir);
Append
(Processed_Value,
(Value => Val,
Alternate => No_Name,
Extracted_From => Get_String_No_Adalib (Current_Dir)));
Visited.Include
(Normalized, External_Value_Lists.Last (Processed_Value));
end if;
end;
end if;
end Save_File;
First : constant Integer := Path_To_Check'First;
Last : Integer;
Val : Name_Id;
begin
if Path_To_Check'Length = 0
or else Path_To_Check = "/"
or else Path_To_Check = "" & Directory_Separator
then
if Group = -1 then
Val := Value_If_Match;
else
Val := Get_String (Group_Match);
end if;
if Contents /= null
and then Is_Regular_File (Current_Dir)
then
Put_Verbose (": Checking inside file " & Current_Dir);
declare
F : File_Type;
begin
Open (F, In_File, Current_Dir);
while not End_Of_File (F) loop
declare
Line : constant String := Get_Line (F);
begin
Put_Verbose (": read line " & Line);
if Match (Contents.all, Line) then
Save_File
(Normalize_Pathname
(Name => Line,
Directory => Dir_Name (Current_Dir),
Resolve_Links => True),
Val);
exit;
end if;
end;
end loop;
Close (F);
end;
else
Save_File (Current_Dir, Val);
end if;
else
-- Do not split on '\', since we document we only accept UNIX paths
-- anyway. This leaves \ for regexp quotes
Last := First + 1;
while Last <= Path_To_Check'Last
and then Path_To_Check (Last) /= '/'
loop
Last := Last + 1;
end loop;
-- If we do not have a regexp.
if not Is_Regexp (Path_To_Check (First .. Last - 1)) then
declare
Dir : constant String :=
Normalize_Pathname
(Current_Dir, Resolve_Links => False)
& Directory_Separator
& Unquote (Path_To_Check (First .. Last - 1));
Remains : constant String :=
Path_To_Check (Last + 1 .. Path_To_Check'Last);
begin
if (Remains'Length = 0
or else Remains = "/"
or else Remains = "" & Directory_Separator)
and then Is_Regular_File (Dir)
then
Put_Verbose (": Found file " & Dir);
-- If there is such a subdir, keep checking
Parse_All_Dirs
(Processed_Value => Processed_Value,
Visited => Visited,
Current_Dir => Dir,
Path_To_Check => Remains,
Regexp => Regexp,
Regexp_Str => Regexp_Str,
Value_If_Match => Value_If_Match,
Group => Group,
Group_Match => Group_Match,
Group_Count => Group_Count,
Contents => Contents,
Merge_Same_Dirs => Merge_Same_Dirs);
elsif Is_Directory (Dir) then
Put_Verbose (": Recurse into " & Dir);
-- If there is such a subdir, keep checking
Parse_All_Dirs
(Processed_Value => Processed_Value,
Visited => Visited,
Current_Dir => Dir & Directory_Separator,
Path_To_Check => Remains,
Regexp => Regexp,
Regexp_Str => Regexp_Str,
Value_If_Match => Value_If_Match,
Group => Group,
Group_Match => Group_Match,
Group_Count => Group_Count,
Contents => Contents,
Merge_Same_Dirs => Merge_Same_Dirs);
else
Put_Verbose (": No such directory: " & Dir);
end if;
end;
-- Else we have a regexp, check all files
else
declare
File_Re : constant String :=
Path_To_Check (First .. Last - 1);
File_Regexp : constant Pattern_Matcher := Compile (File_Re);
Search : Search_Type;
File : Directory_Entry_Type;
Filter : Ada.Directories.Filter_Type;
Continue_Search : Boolean := True;
begin
if Current_Verbosity /= Default and then File_Re = ".." then
Put_Verbose
("Potential error: .. is generally not meant as a regexp,"
& " and should be quoted in this case, as in \.\.");
end if;
if Path_To_Check (Last) = '/' then
Put_Verbose
(": Check directories in " & Current_Dir
& " that match " & File_Re);
Filter := (Directory => True, others => False);
else
Put_Verbose
(": Check files in " & Current_Dir
& " that match " & File_Re);
Filter := (others => True);
end if;
Start_Search
(Search => Search,
Directory => Current_Dir,
Filter => Filter,
Pattern => "");
while Continue_Search loop begin
while More_Entries (Search) loop
Get_Next_Entry (Search, File);
if Simple_Name (File) /= "."
and then Simple_Name (File) /= ".."
then
declare
Matched : Match_Array (0 .. Integer'Max (Group, 0));
Simple : constant String := Simple_Name (File);
Count : constant Natural :=
Paren_Count (File_Regexp);
begin
Match (File_Regexp, Simple, Matched);
if Matched (0) /= No_Match then
Put_Verbose
(": Matched " & Simple_Name (File));
if Group_Count < Group
and then Group_Count + Count >= Group
then
Put_Verbose
(": Found matched group: "
& Simple
(Matched (Group - Group_Count).First
.. Matched (Group - Group_Count).Last));
Parse_All_Dirs
(Processed_Value => Processed_Value,
Visited => Visited,
Current_Dir =>
Full_Name (File) & Directory_Separator,
Path_To_Check => Path_To_Check
(Last + 1 .. Path_To_Check'Last),
Regexp => Regexp,
Regexp_Str => Regexp_Str,
Value_If_Match => Value_If_Match,
Group => Group,
Group_Match =>
Simple
(Matched (Group - Group_Count).First
.. Matched (Group - Group_Count).Last),
Group_Count => Group_Count + Count,
Contents => Contents,
Merge_Same_Dirs => Merge_Same_Dirs);
else
Parse_All_Dirs
(Processed_Value => Processed_Value,
Visited => Visited,
Current_Dir =>
Full_Name (File) & Directory_Separator,
Path_To_Check => Path_To_Check
(Last + 1 .. Path_To_Check'Last),
Regexp => Regexp,
Regexp_Str => Regexp_Str,
Value_If_Match => Value_If_Match,
Group => Group,
Group_Match => Group_Match,
Group_Count => Group_Count + Count,
Contents => Contents,
Merge_Same_Dirs => Merge_Same_Dirs);
end if;
end if;
end;
end if;
end loop;
Continue_Search := False;
exception
when Ada.Directories.Name_Error =>
null;
when Ada.Directories.Use_Error =>
null;
end;
end loop;
End_Search (Search);
end;
end if;
end if;
end Parse_All_Dirs;
------------------------
-- Get_External_Value --
------------------------
procedure Get_External_Value
(Attribute : String;
Value : External_Value;
Comp : Compiler;
Split_Into_Words : Boolean := True;
Merge_Same_Dirs : Boolean := False;
Processed_Value : out External_Value_Lists.List)
is
Saved_Path : constant String :=
Ada.Environment_Variables.Value ("PATH");
Status : aliased Integer;
Extracted_From : Name_Id := No_Name;
Tmp_Result : Unbounded_String;
Node_Cursor : External_Value_Nodes.Cursor := First (Value);
Node : External_Value_Node;
From_Static : Boolean := False;
Visited : String_To_External_Value.Map;
function Get_Command_Output_Cache
(Path : String;
Command : String) return Unbounded_String;
-- Spawns given command and caches results. When the same command
-- (same full path and arguments) should be spawned again,
-- returns output from cache instead.
function Get_Command_Output_Cache
(Path : String;
Command : String) return Unbounded_String
is
Key : constant String := Path & Command;
Cur : constant String_Maps.Cursor := External_Calls_Cache.Find (Key);
Tmp_Result : Unbounded_String;
begin
if Cur = String_Maps.No_Element then
declare
Args : Argument_List_Access :=
Argument_String_To_List (Command);
Output : constant String := Get_Command_Output
(Command => Args (Args'First).all,
Arguments => Args (Args'First + 1 .. Args'Last),
Input => "",
Status => Status'Unchecked_Access,
Err_To_Out => True);
begin
GNAT.Strings.Free (Args);
Tmp_Result := To_Unbounded_String (Output);
External_Calls_Cache.Include (Key, Tmp_Result);
return Tmp_Result;
end;
else
return External_Calls_Cache.Element (Key);
end if;
end Get_Command_Output_Cache;
begin
Clear (Processed_Value);
while Has_Element (Node_Cursor) loop
while Has_Element (Node_Cursor) loop
Node := External_Value_Nodes.Element (Node_Cursor);
case Node.Typ is
when Value_Variable =>
Extracted_From := Node.Var_Name;
when Value_Constant =>
if Node.Value = No_Name then
Tmp_Result := Null_Unbounded_String;
else
Tmp_Result := To_Unbounded_String
(Substitute_Variables_In_Compiler_Description
(Get_Name_String (Node.Value), Comp));
end if;
From_Static := True;
Put_Verbose
(Attribute & ": constant := " & To_String (Tmp_Result));
when Value_Shell =>
Ada.Environment_Variables.Set
("PATH",
Get_Name_String (Comp.Path)
& Path_Separator & Saved_Path);
declare
Command : constant String :=
Substitute_Variables_In_Compiler_Description
(Get_Name_String (Node.Command), Comp);
begin
Tmp_Result := Null_Unbounded_String;
Tmp_Result := Get_Command_Output_Cache
(Get_Name_String (Comp.Path), Command);
Ada.Environment_Variables.Set ("PATH", Saved_Path);
if Current_Verbosity = High then
Put_Verbose (Attribute & ": executing """ & Command
& """ output="""
& To_String (Tmp_Result) & """");
elsif Current_Verbosity = Medium then
Put_Verbose
(Attribute & ": executing """ & Command
& """ output=