------------------------------------------------------------------------------
-- --
-- GPR PROJECT MANAGER --
-- --
-- Copyright (C) 2017-2022, 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.Command_Line; use Ada.Command_Line;
with Ada.Directories;
with Ada.Environment_Variables; use Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO;
with GNAT.Regpat; use GNAT.Regpat;
with GNAT.Sockets;
with GPR.Names; use GPR.Names;
with GPR.Opt; use GPR.Opt;
with GPR.Tempdir;
package body GPR.Util.Aux is
--------------------------------
-- Create_Export_Symbols_File --
--------------------------------
procedure Create_Export_Symbols_File
(Driver_Path : String;
Options : Argument_List;
Sym_Matcher : String;
Format : Export_File_Format;
Objects : String_List;
Library_Symbol_File : String;
Export_File_Name : out Path_Name_Type)
is
use Ada.Text_IO;
use type Ada.Containers.Count_Type;
package Syms_List renames String_Sets;
procedure Get_Syms (Object_File : String);
-- Read exported symbols from Object_File and add them into Syms
procedure Write (Str : String);
-- Write Str into the export file
Pattern : constant Pattern_Matcher := Compile (Sym_Matcher);
Syms : Syms_List.Set;
FD : File_Descriptor;
--------------
-- Get_Syms --
--------------
procedure Get_Syms (Object_File : String) is
Success : Boolean;
Ret : Integer;
Opts : Argument_List (1 .. Options'Length + 1);
File : File_Type;
File_Name : Path_Name_Type;
Matches : Match_Array (0 .. 1);
function Filename return String is (Get_Name_String (File_Name));
-- Remove the ASCII.NUL from end of temporary file-name
begin
Opts (1 .. Options'Length) := Options;
Opts (Opts'Last) := new String'(Object_File);
GPR.Tempdir.Create_Temp_File (FD, File_Name);
Record_Temp_File (null, File_Name);
Close (FD);
if Verbose_Mode then
Put (Driver_Path);
for O of Opts loop
Put (' ');
Put (O.all);
end loop;
New_Line;
end if;
Spawn (Driver_Path, Opts, Filename, Success, Ret);
if Success then
Open (File, In_File, Filename);
while not End_Of_File (File) loop
declare
Buffer : constant String := Get_Line (File);
begin
Match (Pattern, Buffer, Matches);
if Matches (1) /= No_Match then
Syms.Include
(Buffer (Matches (1).First .. Matches (1).Last));
end if;
end;
end loop;
Close (File);
end if;
Free (Opts (Opts'Last));
end Get_Syms;
-----------
-- Write --
-----------
procedure Write (Str : String) is
S : constant String := Str & ASCII.LF;
R : Integer with Unreferenced;
begin
R := Write (FD, S (S'First)'Address, S'Length);
end Write;
begin
Export_File_Name := No_Path;
if Format = None then
return;
end if;
if Library_Symbol_File = "" then
-- Get the exported symbols from every object files, first get the nm
-- tool for the target.
for K in Objects'Range loop
Get_Syms (Objects (K).all);
end loop;
else
-- Get the symbols from the symbol file, one symbol per line
if Is_Readable_File (Library_Symbol_File) then
declare
File : File_Type;
Line : String (1 .. 1_024);
Last : Natural;
begin
Open (File, In_File, Library_Symbol_File);
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
if Last > 0 then
Syms.Include (Line (1 .. Last));
end if;
end loop;
Close (File);
end;
else
raise Constraint_Error
with "unable to locate Library_Symbol_File"""
& Library_Symbol_File & '"';
end if;
end if;
if Syms.Length = 0 then
return;
end if;
-- Now create the export file, either GNU or DEF format
Create_Export_File : declare
File_Name : Path_Name_Type;
Success : Boolean;
begin
-- Create (Export_File, Out_File);
GPR.Tempdir.Create_Temp_File (FD, File_Name);
Record_Temp_File (null, File_Name);
Get_Name_String (File_Name);
-- Always add .def at the end, this is needed for Windows
Add_Str_To_Name_Buffer (".def");
Export_File_Name := Name_Find;
Record_Temp_File (null, Export_File_Name);
-- Header
case Format is
when GNU =>
Write ("SYMS {");
Write (" global:");
when Def =>
Write ("EXPORTS");
when None | Flat =>
null;
end case;
-- Symbols
for Sym of Syms loop
case Format is
when GNU =>
Write (Sym & ";");
when Def | Flat =>
Write (Sym);
when None =>
null;
end case;
end loop;
-- Footer
case Format is
when GNU =>
Write (" local: *;");
Write ("};");
when None | Def | Flat =>
null;
end case;
Close (FD);
Copy_File
(Get_Name_String (File_Name),
Get_Name_String (Export_File_Name),
Success);
if not Success then
Fail_Program
(null,
"couldn't create an export file " &
Get_Name_String (Export_File_Name));
end if;
end Create_Export_File;
end Create_Export_Symbols_File;
--------------------------
-- Create_Response_File --
--------------------------
procedure Create_Response_File
(Format : Response_File_Format;
Objects : String_List;
Other_Arguments : String_List;
Resp_File_Options : String_List;
Name_1 : out Path_Name_Type;
Name_2 : out Path_Name_Type)
is
Objects_Vector : String_Vectors.Vector;
Other_Args_Vector : String_Vectors.Vector;
Resp_File_Options_Vector : String_Vectors.Vector;
begin
for J in Objects'Range loop
Objects_Vector.Append (Objects (J).all);
end loop;
for J in Other_Arguments'Range loop
Other_Args_Vector.Append (Other_Arguments (J).all);
end loop;
for J in Resp_File_Options'Range loop
Resp_File_Options_Vector.Append (Resp_File_Options (J).all);
end loop;
Create_Response_File
(Format,
Objects_Vector,
Other_Args_Vector,
Resp_File_Options_Vector,
Name_1,
Name_2);
end Create_Response_File;
--------------------------
-- Create_Response_File --
--------------------------
procedure Create_Response_File
(Format : Response_File_Format;
Objects : String_Vectors.Vector;
Other_Arguments : String_Vectors.Vector;
Resp_File_Options : String_Vectors.Vector;
Name_1 : out Path_Name_Type;
Name_2 : out Path_Name_Type)
is
GNU_Header : aliased constant String := "INPUT (";
GNU_Opening : aliased constant String := """";
GNU_Closing : aliased constant String := '"' & ASCII.LF;
GNU_Footer : aliased constant String := ')' & ASCII.LF;
Resp_File : File_Descriptor;
Status : Integer;
pragma Warnings (Off, Status);
Closing_Status : Boolean;
pragma Warnings (Off, Closing_Status);
function Modified_Argument (Arg : String) return String;
-- If the argument includes a space, a backslash, or a double quote,
-- escape the character with a preceding backsash.
-----------------------
-- Modified_Argument --
-----------------------
function Modified_Argument (Arg : String) return String is
Result : String (1 .. 2 * Arg'Length);
Last : Natural := 0;
procedure Add (C : Character);
---------
-- Add --
---------
procedure Add (C : Character) is
begin
Last := Last + 1;
Result (Last) := C;
end Add;
begin
for J in Arg'Range loop
if Arg (J) = '\' or else Arg (J) = ' ' or else Arg (J) = '"' then
Add ('\');
end if;
Add (Arg (J));
end loop;
return Result (1 .. Last);
end Modified_Argument;
begin
Name_2 := No_Path;
Tempdir.Create_Temp_File (Resp_File, Name => Name_1);
Record_Temp_File (null, Name_1);
if Format = GNU or else Format = GCC_GNU then
Status := Write (Resp_File, GNU_Header'Address, GNU_Header'Length);
end if;
for Object of Objects loop
if Format = GNU or else Format = GCC_GNU then
Status :=
Write (Resp_File, GNU_Opening'Address, GNU_Opening'Length);
end if;
Status :=
Write (Resp_File, Object (1)'Address, Object'Length);
if Format = GNU or else Format = GCC_GNU then
Status :=
Write (Resp_File, GNU_Closing'Address, GNU_Closing'Length);
else
Status :=
Write (Resp_File, ASCII.LF'Address, 1);
end if;
end loop;
if Format = GNU or else Format = GCC_GNU then
Status := Write (Resp_File, GNU_Footer'Address, GNU_Footer'Length);
end if;
case Format is
when GCC_GNU | GCC_Object_List | GCC_Option_List =>
Close (Resp_File, Closing_Status);
Name_2 := Name_1;
Tempdir.Create_Temp_File (Resp_File, Name => Name_1);
Record_Temp_File (null, Name_1);
for Option of Resp_File_Options loop
Status :=
Write
(Resp_File,
Option (1)'Address,
Option'Length);
if Option /= Resp_File_Options.Last_Element then
Status := Write (Resp_File, ASCII.LF'Address, 1);
end if;
end loop;
declare
Arg : constant String :=
Modified_Argument (Get_Name_String (Name_2));
begin
Status := Write (Resp_File, Arg (1)'Address, Arg'Length);
end;
Status := Write (Resp_File, ASCII.LF'Address, 1);
when GCC =>
null;
when others =>
Close (Resp_File, Closing_Status);
end case;
if Format = GCC
or else Format = GCC_GNU
or else Format = GCC_Object_List
or else Format = GCC_Option_List
then
for Argument of Other_Arguments loop
declare
Arg : constant String :=
Modified_Argument (Argument);
begin
Status := Write (Resp_File, Arg (1)'Address, Arg'Length);
end;
Status := Write (Resp_File, ASCII.LF'Address, 1);
end loop;
Close (Resp_File, Closing_Status);
end if;
end Create_Response_File;
-----------------------
-- Compute_Slave_Env --
-----------------------
function Compute_Slave_Env
(Project : Project_Tree_Ref; Auto : Boolean) return String
is
User : String_Access := Getenv ("USER");
User_Name : String_Access := Getenv ("USERNAME");
Default : constant String :=
(if User = null
then (if User_Name = null
then "unknown" else User_Name.all)
else User.all)
& '@' & GNAT.Sockets.Host_Name;
package S_Set renames String_Sets;
Set : S_Set.Set;
Ctx : Context;
begin
Free (User);
Free (User_Name);
if Auto then
-- In this mode the slave environment is computed based on
-- the project variable value and the command line arguments.
-- First adds all command line arguments
for K in 1 .. Argument_Count loop
-- Skip arguments that are not changing the actual compilation and
-- this will ensure that the same environment will be created for
-- gprclean.
if Argument (K) not in "-p" | "-d" | "-c" | "-q"
and then
(Argument (K)'Length < 2
or else Argument (K) (1 .. 2) /= "-j")
then
Set.Insert (Argument (K));
end if;
end loop;
-- Then all the global variables for the project tree
for K in
1 .. Variable_Element_Table.Last (Project.Shared.Variable_Elements)
loop
declare
V : constant Variable :=
Project.Shared.Variable_Elements.Table (K);
begin
if V.Value.Kind = Single then
Set.Include
(Get_Name_String (V.Name)
& "=" & Get_Name_String (V.Value.Value));
end if;
end;
end loop;
-- Compute the MD5 sum of the sorted elements in the set
for S of Set loop
Update (Ctx, S);
end loop;
return Default & "-" & Digest (Ctx);
else
-- Otherwise use the default & '@' &
return Default;
end if;
end Compute_Slave_Env;
----------------------
-- Get_Slaves_Hosts --
----------------------
function Get_Slaves_Hosts
(Project_Tree : Project_Tree_Ref;
Arg : String) return String
is
use Ada.Strings.Unbounded;
Hosts : Unbounded_String;
begin
if Arg'Length > Distributed_Option'Length
and then Arg (Arg'First + Distributed_Option'Length) = '='
then
-- The hosts are specified on the command-line
Hosts := To_Unbounded_String
(Arg (Arg'First + Distributed_Option'Length + 1 .. Arg'Last));
elsif Environment_Variables.Exists ("GPR_SLAVES") then
Hosts := To_Unbounded_String (Value ("GPR_SLAVES"));
elsif Environment_Variables.Exists ("GPR_SLAVES_FILE") then
declare
F_Name : constant String := Value ("GPR_SLAVES_FILE");
F : Text_IO.File_Type;
Buffer : String (1 .. 100);
Last : Natural;
begin
if Directories.Exists (F_Name) then
Text_IO.Open (F, Text_IO.In_File, F_Name);
while not Text_IO.End_Of_File (F) loop
Text_IO.Get_Line (F, Buffer, Last);
if Last > 0 then
if Hosts /= Null_Unbounded_String then
Append (Hosts, ",");
end if;
Append (Hosts, Buffer (1 .. Last));
end if;
end loop;
Text_IO.Close (F);
else
Fail_Program
(Project_Tree,
"hosts distributed file " & F_Name & " not found",
Exit_Code => E_General);
end if;
end;
end if;
return To_String (Hosts);
end Get_Slaves_Hosts;
end GPR.Util.Aux;