------------------------------------------------------------------------------ -- -- -- GPR2 PROJECT MANAGER -- -- -- -- Copyright (C) 2019-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software 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. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with Ada.Containers.Indefinite_Ordered_Sets; with Ada.Containers.Vectors; with Ada.Directories; with Ada.Strings.Equal_Case_Insensitive; with Ada.Strings.Fixed; with Ada.Strings.Less_Case_Insensitive; with Ada.Strings.Unbounded; with Ada.Text_IO; with GNAT.MD5; with GNAT.OS_Lib; with GNAT.String_Split; with GNATCOLL.OS.Constants; with GPR2.Unit.List; with GPR2.Containers; with GPR2.Path_Name; with GPR2.Project.Attribute; with GPR2.Project.Attribute_Index; with GPR2.Project.Registry.Attribute; with GPR2.Project.Registry.Pack; with GPR2.Project.Source.Artifact; with GPR2.Project.Source.Set; pragma Warnings (Off, "* is not referenced"); -- GPR2.Project.Source.Dependencies return a Part_Set but only has limited -- visibility on it. So in order to be able to manipulate the returned object -- we need to have full vilibility so need to add this with clause. -- However we never reference the package explicitly, so the compiler will -- complain that the using is not referenced. -- So let's just kill the warning. with GPR2.Project.Source.Part_Set; pragma Warnings (On, "* is not referenced"); with GPR2.Project.Typ; with GPR2.Project.Variable; with GPR2.Project.View.Set; with GPR2.Version; with GPR2.Source_Reference; with GPR2.Source_Reference.Value; with GPRtools; with GPRtools.Util; package body GPRinstall.Install is use Ada; use Ada.Strings.Unbounded; use Ada.Text_IO; use GNAT; use GPR2; use all type Unit.Library_Unit_Type; use type GNATCOLL.OS.OS_Type; package String_Vector renames GPR2.Containers.Value_Type_List; subtype Message_Digest is GNAT.MD5.Message_Digest; Is_Windows_Host : constant Boolean := GNATCOLL.OS.Constants.OS = GNATCOLL.OS.Windows with Warnings => Off; Content : String_Vector.Vector; -- The content of the project, this is used when creating the project -- and is needed to ease the project section merging when installing -- multiple builds. Initial_Buffer_Size : constant := 100; -- Arbitrary value for the initial size of the buffer below Buffer : GNAT.OS_Lib.String_Access := new String (1 .. Initial_Buffer_Size); Buffer_Last : Natural := 0; Agg_Manifest : Text_IO.File_Type; -- Manifest file for main aggregate project Line_Manifest : Text_IO.Count := 0; Line_Agg_Manifest : Text_IO.Count := 0; -- Keep lines when opening the manifest files. This is used by the rollback -- routine when an error occurs while copying the files. Installed : GPR2.Project.View.Set.Object; -- Record already installed project function Other_Part_Need_Body (Source : GPR2.Project.Source.Object; Index : Unit_Index) return Boolean is (Source.Has_Other_Part (Index) and then Source.Other_Part (Index).Source.Is_Implementation_Required (Source.Other_Part (Index).Index)); -- Returns True if Source has other part and this part need body procedure Double_Buffer; -- Double the size of the Buffer procedure Write_Eol; -- Append the content of the Buffer as a line to Content and empty the -- Buffer. procedure Write_Str (S : String); -- Append S to the buffer. Double the buffer if needed procedure Process (Tree : GPR2.Project.Tree.Object; Project : GPR2.Project.View.Object; Options : GPRinstall.Options.Object); -- Install the give project view ------------------- -- Double_Buffer -- ------------------- procedure Double_Buffer is New_Buffer : constant GNAT.OS_Lib.String_Access := new String (1 .. Buffer'Last * 2); begin New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); OS_Lib.Free (Buffer); Buffer := New_Buffer; end Double_Buffer; ------------- -- Process -- ------------- procedure Process (Tree : GPR2.Project.Tree.Object; Project : GPR2.Project.View.Object; Options : GPRinstall.Options.Object) is use GPRtools; use GPRtools.Util; use type GPR2.Path_Name.Object; use type GPR2.Project.View.Object; package A renames GPR2.Project.Registry.Attribute; package P renames GPR2.Project.Registry.Pack; subtype Param is GPRinstall.Options.Param; Target_Name : constant String := String (Options.Target); Objcopy_Exec : constant String := (if Target_Name = "all" then "objcopy" else Target_Name & "-objcopy"); -- Name of objcopy executable, possible a cross one Strip_Exec : constant String := (if Target_Name = "all" then "strip" else Target_Name & "-strip"); -- Name of strip executable, possible a cross one Objcopy : constant String := Locate_Exec_On_Path (Objcopy_Exec); Strip : constant String := Locate_Exec_On_Path (Strip_Exec); Windows_Target : constant Boolean := Tree.Is_Windows_Target; -- Local values for the given project, these are initially set with the -- default values. It is updated using the Install package found in the -- project if any. Active : Boolean := True; -- Whether installation is active or not (Install package's attribute) Side_Debug : Boolean := Options.Side_Debug; -- Whether to extract debug symbols from executables and shared -- libraries. Default to global value. Prefix_Dir : Param := Options.Global_Prefix_Dir; Exec_Subdir : Param := Options.Global_Exec_Subdir; Lib_Subdir : Param := Options.Global_Lib_Subdir; ALI_Subdir : Param := Options.Global_ALI_Subdir; Link_Lib_Subdir : Param := Options.Global_Link_Lib_Subdir; Sources_Subdir : Param := Options.Global_Sources_Subdir; Project_Subdir : Param := Options.Global_Project_Subdir; Install_Mode : Param := Options.Global_Install_Mode; Install_Name : Param := Options.Global_Install_Name; Install_Project : Boolean := not Options.No_GPR_Install; type Items is (Source, Object, Dependency, Library, Executable); Copy : array (Items) of Boolean := (others => False); -- What should be copied from a project, this depends on the actual -- project kind and the mode (usage, dev) set for the install. Man : Text_IO.File_Type; -- File where manifest for this project is kept -- Keeping track of artifacts to install type Artifacts_Data is record Destination, Filename : Unbounded_String; Required : Boolean; end record; package Artifacts_Set is new Ada.Containers.Vectors (Positive, Artifacts_Data); Artifacts : Artifacts_Set.Vector; Excluded_Naming : GPR2.Containers.Name_Set; -- This set contains names of Ada unit to exclude from the generated -- package Naming. This is needed to avoid renaming for bodies which -- are not installed when the minimum installation (-m) is used. In -- this case there is two points to do: -- -- 1. the installed .ali must use the spec naming -- -- 2. the naming convention for the body must be excluded from the -- generated project. procedure Copy_File (From, To : Path_Name.Object; File : Filename_Optional := No_Filename; From_Ver : Path_Name.Object := Path_Name.Undefined; Sym_Link : Boolean := False; Executable : Boolean := False; Extract_Debug : Boolean := False) with Pre => (if From.Is_Directory then not To.Is_Directory or else File /= No_Filename else To.Is_Directory or else File = No_Filename); -- Copy file From into To. If From and To are directories the full path -- name is using the File which must not be empty in this case. -- If Sym_Link is set a symbolic link is created. -- If Executable is set, the destination file exec attribute is set. -- When Extract_Debug is set to True the debug information for the -- executable is written in a side file. function Dir_Name (Suffix : Boolean := True) return Filename_Type; -- Returns the name of directory where project files are to be -- installed. This name is the name of the project. If Suffix is -- True then the build name is also returned. function Sources_Dir (Build_Name : Boolean := True) return Path_Name.Object; -- Returns the full pathname to the sources destination directory function Prefix_For_Dir (Name : String) return Path_Name.Object is (Path_Name.Create_Directory (Filename_Type (Name), (if OS_Lib.Is_Absolute_Path (Name) then No_Filename else Filename_Optional (-Prefix_Dir.V)))); -- Returns directory as Path_Name.Object prefixed with Prefix_Dir.V.all -- if not absote. function Exec_Dir return Path_Name.Object; -- Returns the full pathname to the executable destination directory function Lib_Dir (Build_Name : Boolean := True) return Path_Name.Object; -- Returns the full pathname to the library destination directory function ALI_Dir (Build_Name : Boolean := True) return Path_Name.Object; -- Returns the full pathname to the library destination directory function Link_Lib_Dir return Path_Name.Object; -- Returns the full pathname to the lib symlib directory function Project_Dir return Path_Name.Object; -- Returns the full pathname to the project destination directory procedure Check_Install_Package; -- Check Project's install package and overwrite the default values of -- the corresponding variables above. procedure Copy_Files; -- Do the file copies for the project's sources, objects, library, -- executables. procedure Create_Project (Project : GPR2.Project.View.Object); -- Create install project for the given project procedure Add_To_Manifest (Pathname : Path_Name.Object; Aggregate_Only : Boolean := False) with Pre => Options.Install_Manifest; -- Add filename to manifest function Has_Sources (Project : GPR2.Project.View.Object) return Boolean with Inline; -- Returns True if the project contains sources function Is_Install_Active (Project : GPR2.Project.View.Object) return Boolean; -- Returns True if the Project is active, that is there is no attribute -- Active set to False in the Install package. procedure Open_Check_Manifest (File : out Text_IO.File_Type; Current_Line : out Text_IO.Count); -- Check that manifest file can be used procedure Rollback_Manifests; -- Rollback manifest files (for current project or/and aggregate one) function For_Dev return Boolean is (-Install_Mode.V = "dev"); function Build_Subdir (Subdir : Param; Build_Name : Boolean := True) return Path_Name.Object; -- Return a path-name for a subdir --------------------- -- Add_To_Manifest -- --------------------- procedure Add_To_Manifest (Pathname : Path_Name.Object; Aggregate_Only : Boolean := False) is begin if not Aggregate_Only and then not Is_Open (Man) then Open_Check_Manifest (Man, Line_Manifest); end if; -- Append entry into manifest declare function N (Str : String) return String is (OS_Lib.Normalize_Pathname (Str, Case_Sensitive => False)); MD5 : constant String := String (Pathname.Content_MD5); begin if not Aggregate_Only and then Is_Open (Man) then declare Man_Path : constant Path_Name.Object := Path_Name.Create_File (Filename_Type (N (Name (Man))), Path_Name.No_Resolution); begin Put_Line (Man, MD5 & ' ' & String (Pathname.Relative_Path (From => Man_Path).Name)); end; end if; if Is_Open (Agg_Manifest) then declare Agg_Man_Path : constant Path_Name.Object := Path_Name.Create_File (Filename_Type (N (Name (Agg_Manifest))), Path_Name.No_Resolution); begin Put_Line (Agg_Manifest, MD5 & ' ' & String (Pathname.Relative_Path (From => Agg_Man_Path).Name)); end; end if; end; end Add_To_Manifest; ------------- -- ALI_Dir -- ------------- function ALI_Dir (Build_Name : Boolean := True) return Path_Name.Object is begin return Build_Subdir (ALI_Subdir, Build_Name); end ALI_Dir; ------------------ -- Build_Subdir -- ------------------ function Build_Subdir (Subdir : Param; Build_Name : Boolean := True) return Path_Name.Object is Install_Name_Dir : constant Filename_Type := (if Install_Name.Default then "." else Filename_Type (-Install_Name.V)); begin if OS_Lib.Is_Absolute_Path (-Subdir.V) then return Path_Name.Create_Directory (Install_Name_Dir, Filename_Optional (-Subdir.V)); elsif not Subdir.Default or else not Build_Name then return Path_Name.Create_Directory (Install_Name_Dir, Filename_Type (Path_Name.Create_Directory (Filename_Type (-Subdir.V), Filename_Optional (-Prefix_Dir.V)).Value)); else return Path_Name.Create_Directory (Dir_Name, Filename_Type (Path_Name.Create_Directory (Install_Name_Dir, Filename_Type (Path_Name.Create_Directory (Filename_Type (-Subdir.V), Filename_Optional (-Prefix_Dir.V)).Value)) .Value)); end if; end Build_Subdir; --------------------------- -- Check_Install_Package -- --------------------------- procedure Check_Install_Package is procedure Replace (P : in out Param; Val : String; Is_Dir : Boolean := True; Normalize : Boolean := False) with Inline; -- Set Var with Value, free previous pointer ------------- -- Replace -- ------------- procedure Replace (P : in out Param; Val : String; Is_Dir : Boolean := True; Normalize : Boolean := False) is begin if Val /= "" then P := (To_Unbounded_String ((if Is_Dir then (if Normalize then OS_Lib.Normalize_Pathname (Val) else Val) else Val)), Default => False); end if; end Replace; begin if Project.Has_Package (P.Install) then declare use Characters.Handling; begin for V of Project.Attributes (Pack => P.Install) loop if V.Name.Id = A.Install.Prefix then -- If Install.Prefix is a relative path, it is made -- relative to the global prefix. if OS_Lib.Is_Absolute_Path (V.Value.Text) then if Options.Global_Prefix_Dir.Default then Replace (Prefix_Dir, V.Value.Text, Normalize => True); end if; else Replace (Prefix_Dir, -Options.Global_Prefix_Dir.V & "/" & V.Value.Text, Normalize => True); end if; elsif V.Name.Id = A.Install.Exec_Subdir and then Options.Global_Exec_Subdir.Default then Replace (Exec_Subdir, V.Value.Text); elsif V.Name.Id = A.Install.Lib_Subdir and then Options.Global_Lib_Subdir.Default then Replace (Lib_Subdir, V.Value.Text); elsif V.Name.Id = A.Install.ALI_Subdir and then Options.Global_ALI_Subdir.Default then Replace (ALI_Subdir, V.Value.Text); elsif V.Name.Id = A.Install.Link_Lib_Subdir and then Options.Global_Link_Lib_Subdir.Default then Replace (Link_Lib_Subdir, V.Value.Text); elsif V.Name.Id = A.Install.Sources_Subdir and then Options.Global_Sources_Subdir.Default then Replace (Sources_Subdir, V.Value.Text); elsif V.Name.Id = A.Install.Project_Subdir and then Options.Global_Project_Subdir.Default then Replace (Project_Subdir, V.Value.Text); elsif V.Name.Id = A.Install.Mode and then Options.Global_Install_Mode.Default then Replace (Install_Mode, V.Value.Text); elsif V.Name.Id = A.Install.Install_Name and then Options.Global_Install_Name.Default then Replace (Install_Name, V.Value.Text, Is_Dir => False); elsif V.Name.Id = A.Install.Active then declare Val : constant String := To_Lower (V.Value.Text); begin if Val = "false" then Active := False; else Active := True; end if; end; elsif V.Name.Id = A.Install.Side_Debug then declare Val : constant String := To_Lower (V.Value.Text); begin if Val = "true" then Side_Debug := True; else Side_Debug := False; end if; end; elsif V.Name.Id = A.Install.Install_Project then declare Val : constant String := To_Lower (V.Value.Text); begin if Val = "false" then Install_Project := False; else Install_Project := True; end if; end; elsif V.Name.Id in A.Install.Artifacts | A.Install.Required_Artifacts then declare Destination : constant Unbounded_String := (if V.Index.Text = "" then To_Unbounded_String (".") else To_Unbounded_String (V.Index.Text)); begin for S of V.Values loop Artifacts.Append (Artifacts_Data' (Destination, To_Unbounded_String (S.Text), Required => (if V.Name.Id = A.Install.Artifacts then False else True))); end loop; end; end if; end loop; end; end if; -- Now check if Lib_Subdir is set and not ALI_Subdir as in this case -- we want ALI_Subdir to be equal to Lib_Subdir. if not Lib_Subdir.Default and then ALI_Subdir.Default then ALI_Subdir := Lib_Subdir; end if; end Check_Install_Package; --------------- -- Copy_File -- --------------- procedure Copy_File (From, To : Path_Name.Object; File : Filename_Optional := No_Filename; From_Ver : Path_Name.Object := Path_Name.Undefined; Sym_Link : Boolean := False; Executable : Boolean := False; Extract_Debug : Boolean := False) is Src_Path : constant Path_Name.Object := (if From.Is_Directory then From.Compose (if File = No_Filename then To.Simple_Name else File) else From); F : constant String := String (Src_Path.Value); Dest_Path : constant Path_Name.Object := (if To.Is_Directory then To.Compose (if File = No_Filename then From.Simple_Name else File) else To); T : constant String := String (Dest_Path.Dir_Name); Dest_Filename : aliased String := Dest_Path.Value; begin pragma Warnings (Off, "*can never be executed*"); if Sym_Link and then Is_Windows_Host then raise GPRinstall_Error with "internal error: cannot use symbolic links on Windows"; end if; pragma Warnings (On, "*can never be executed*"); if not Sym_Link and then Directories.Exists (Dest_Filename) and then not Options.Force_Installations and then Src_Path.Content_MD5 /= Dest_Path.Content_MD5 then raise GPRinstall_Error with "file " & String (File) & " exists, use -f to overwrite"; end if; if Options.Dry_Run or else Options.Verbose then if Sym_Link then Put ("ln -s "); else Put ("cp "); end if; Put (F); Put (" "); Put (Dest_Filename); New_Line; end if; if not Options.Dry_Run then -- If file exists and is read-only, first remove it if not Sym_Link and then Directories.Exists (Dest_Filename) then if not OS_Lib.Is_Writable_File (Dest_Filename) then OS_Lib.Set_Writable (Dest_Filename); end if; declare Success : Boolean; begin OS_Lib.Delete_File (Dest_Filename, Success); if not Success then raise GPRinstall_Error with "cannot overwrite " & Dest_Filename & " check permissions"; end if; end; end if; if not Sym_Link and then not Src_Path.Exists then raise GPRinstall_Error with "file " & F & " does not exist, build may not be complete"; end if; if (not Sym_Link and then not Directories.Exists (T)) or else (Sym_Link and then not Src_Path.Exists) then if Options.Create_Dest_Dir then begin if Sym_Link then Directories.Create_Path (Src_Path.Dir_Name); else Directories.Create_Path (T); end if; exception when Text_IO.Use_Error => -- Cannot create path, permission issue raise GPRinstall_Error with "cannot create destination directory " & (if Sym_Link then Src_Path.Dir_Name else T) & " check permissions"; end; else raise GPRinstall_Error with "target directory " & T & " does not exist, use -p to create"; end if; end if; -- Do copy if Sym_Link then Src_Path.Create_Sym_Link (To => Dest_Path); -- Add file to manifest if Options.Install_Manifest then Add_To_Manifest (Src_Path); end if; if From_Ver.Is_Defined then From_Ver.Create_Sym_Link (To => Dest_Path); if Options.Install_Manifest then Add_To_Manifest (From_Ver); end if; end if; else begin Ada.Directories.Copy_File (Source_Name => F, Target_Name => Dest_Filename, Form => "preserve=timestamps"); exception when Text_IO.Use_Error => raise GPRinstall_Error with "cannot overwrite file " & Dest_Filename & " check permissions."; end; if Executable then declare use OS_Lib; begin OS_Lib.Set_Executable (Dest_Filename, Mode => S_Owner + S_Group + S_Others); end; -- Furthermore, if we have an executable and we ask for -- separate debug symbols we do it now. -- The commands to run are: -- $ objcopy --only-keep-debug .debug -- $ strip -- $ objcopy --add-gnu-debuglink=.debug if Extract_Debug then if Objcopy = "" then Put_Line (Objcopy_Exec & " not found, " & "cannot create side debug file for " & Dest_Filename); elsif Strip = "" then Put_Line (Strip_Exec & " not found, " & "cannot create side debug file for " & Dest_Filename); else declare Keep_Debug : aliased String := "--only-keep-debug"; Dest_Debug : aliased String := Dest_Filename & ".debug"; Link_Debug : aliased String := "--add-gnu-debuglink=" & Dest_Debug; Success : Boolean; Args : OS_Lib.Argument_List (1 .. 3); begin -- 1. copy the debug symbols: Args (1) := Keep_Debug'Unchecked_Access; Args (2) := Dest_Filename'Unchecked_Access; Args (3) := Dest_Debug'Unchecked_Access; OS_Lib.Spawn (Objcopy, Args, Success); if Success then -- Record the debug file in the manifest if Options.Install_Manifest then Add_To_Manifest (Path_Name.Create_File (Filename_Type (Dest_Debug))); end if; -- 2. strip original executable Args (1) := Dest_Filename'Unchecked_Access; OS_Lib.Spawn (Strip, Args (1 .. 1), Success); if Success then -- 2. link debug symbols file with original -- file. Args (1) := Link_Debug'Unchecked_Access; Args (2) := Dest_Filename'Unchecked_Access; OS_Lib.Spawn (Objcopy, Args (1 .. 2), Success); if not Success then Put_Line (Objcopy_Exec & " error, " & "cannot link debug symbol file with" & " original executable " & Dest_Filename); end if; else Put_Line (Strip_Exec & " error, " & "cannot remove debug symbols from " & Dest_Filename); end if; else Put_Line (Objcopy_Exec & " error, " & "cannot create side debug file for " & Dest_Filename); end if; end; end if; end if; end if; -- Add file to manifest if Options.Install_Manifest then Add_To_Manifest (Dest_Path); end if; end if; end if; end Copy_File; ---------------- -- Copy_Files -- ---------------- procedure Copy_Files is procedure Copy_Project_Sources (Project : GPR2.Project.View.Object); -- Copy sources from the given project function Copy_Source (Source : GPR2.Project.Source.Object) return Boolean; -- Copy Source and returns either artefactes need to be copied too procedure Copy_Artifacts (Pathname : Path_Name.Object; Destination : Path_Name.Object; Required : Boolean); -- Copy items from the artifacts attribute Source_Copied : GPR2.Project.Source.Set.Object; -------------------- -- Copy_Artifacts -- -------------------- procedure Copy_Artifacts (Pathname : Path_Name.Object; Destination : Path_Name.Object; Required : Boolean) is use Ada.Directories; procedure Copy_Entry (E : Directory_Entry_Type); -- Copy file pointed by E Something_Copied : Boolean := False; -- Keep track if something has been copied or not. If an artifact -- is coming from Required_Artifacts we must ensure that there is -- actually something copied if we have a directory or wildcards. ---------------- -- Copy_Entry -- ---------------- procedure Copy_Entry (E : Directory_Entry_Type) is Fullname : constant String := Full_Name (E); Dest_Dir : constant Path_Name.Object := Path_Name.Create_Directory (Filename_Type (Destination.Value), Filename_Optional (-Prefix_Dir.V)); begin if Kind (E) = Directory and then Directories.Simple_Name (E) /= "." and then Directories.Simple_Name (E) /= ".." then Copy_Artifacts (Path_Name.Create_File ("*", Filename_Optional (Fullname)), Path_Name.Compose (Dest_Dir, Filename_Type (Directories.Simple_Name (E)), Directory => True), Required); elsif Kind (E) = Ordinary_File then Copy_File (From => Path_Name.Create_File (Filename_Type (Fullname)), To => Destination, Executable => OS_Lib.Is_Executable_File (Fullname)); if Required then Something_Copied := True; end if; end if; end Copy_Entry; begin Ada.Directories.Search (Directory => Pathname.Dir_Name, Pattern => String (Pathname.Simple_Name), Process => Copy_Entry'Access); if Required and not Something_Copied then Rollback_Manifests; raise GPRinstall_Error with "error: file does not exist '" & Pathname.Value & '''; end if; exception when Text_IO.Name_Error => if Required then Rollback_Manifests; raise GPRinstall_Error with "error: file does not exist '" & Pathname.Value & '''; elsif Options.Warnings then Put_Line ("warning: file does not exist '" & Pathname.Value & '''); end if; end Copy_Artifacts; -------------------------- -- Copy_Project_Sources -- -------------------------- procedure Copy_Project_Sources (Project : GPR2.Project.View.Object) is function Is_Ada (Source : GPR2.Project.Source.Object) return Boolean is (Source.Language = Ada_Language); -- Returns True if Source is an Ada source procedure Install_Project_Source (Source : GPR2.Project.Source.Object; Is_Interface_Closure : Boolean := False); -- Install the project source and possibly the corresponding -- artifacts. procedure Copy_Interface_Closure (Source : GPR2.Project.Source.Object; Index : GPR2.Unit_Index) with Pre => Source.Has_Units; -- Copy all sources and artifacts part of the close of Source ---------------------------- -- Copy_Interface_Closure -- ---------------------------- procedure Copy_Interface_Closure (Source : GPR2.Project.Source.Object; Index : GPR2.Unit_Index) is begin -- Note that we only install the interface from the same view -- to avoid installing the runtime file for example. for D of Source.Dependencies (Index, Closure => True, Sorted => False) loop if not Source_Copied.Contains (D.Source) and then (D.Source.Kind (D.Index) in Unit.Spec_Kind or else Other_Part_Need_Body (D.Source, D.Index)) and then Source.View = D.Source.View then Install_Project_Source (D.Source, Is_Interface_Closure => True); end if; end loop; end Copy_Interface_Closure; ---------------------------- -- Install_Project_Source -- ---------------------------- procedure Install_Project_Source (Source : GPR2.Project.Source.Object; Is_Interface_Closure : Boolean := False) is Atf : GPR2.Project.Source.Artifact.Object; CUs : GPR2.Unit.List.Object; Done : Boolean := True; Has_Atf : Boolean := False; -- Has artefacts to install function Is_Interface return Boolean; -- Returns True if Source is an interface (spec or body) procedure Copy_ALI_Other_Part (From : GPR2.Path_Name.Object; To : GPR2.Path_Name.Object; Source : GPR2.Project.Source.Object) with Pre => Source.Has_Other_Part; -- Copy ALI for other part of source if the naming exception -- brings different base names for the spec and body. ------------------------- -- Copy_ALI_Other_Part -- ------------------------- procedure Copy_ALI_Other_Part (From : GPR2.Path_Name.Object; To : GPR2.Path_Name.Object; Source : GPR2.Project.Source.Object) is S_BN : constant String := String (Source.Path_Name.Base_Name); O_Src : constant GPR2.Project.Source.Object := Source.Other_Part.Source; O_BN : constant String := String (O_Src.Path_Name.Base_Name); D_Sfx : constant String := String (Source.View.Tree.Dependency_Suffix (Source.Language)); begin if S_BN /= O_BN then Copy_File (From => From, To => To, File => Filename_Optional (O_BN & D_Sfx)); end if; end Copy_ALI_Other_Part; ------------------ -- Is_Interface -- ------------------ function Is_Interface return Boolean is begin return Source.Is_Interface or else (Source.Has_Other_Part and then Source.Other_Part.Source.Is_Interface); end Is_Interface; begin -- Skip sources that are removed/excluded and sources not -- part of the interface for standalone libraries. Atf := Source.Artifacts; if not Project.Is_Library or else not Project.Is_Library_Standalone or else Is_Interface_Closure or else Is_Interface then if Source.Has_Units then CUs := Source.Units; end if; if Options.All_Sources or else Source.Kind in Unit.Spec_Kind or else Other_Part_Need_Body (Source, No_Index) or else Source.Is_Generic (No_Index) or else (Source.Kind = S_Separate and then Source.Separate_From (No_Index).Source.Is_Generic (No_Index)) then Done := Copy_Source (Source); -- If this source is an interface of the project we -- need to also install the full-closure for this source. if Source.Is_Interface and then Source.Has_Units and then not Is_Interface_Closure then if Source.Has_Units then for CU of CUs loop Copy_Interface_Closure (Source, CU.Index); end loop; else Copy_Interface_Closure (Source, No_Index); end if; end if; elsif Source.Has_Naming_Exception then -- When a naming exception is present for a body which -- is not installed we must exclude the Naming from the -- generated project. for CU of CUs loop Excluded_Naming.Include (CU.Name); end loop; end if; -- Objects / Deps Check_For_Artefacts : for CU of CUs loop if CU.Kind not in S_Spec | S_Separate then Has_Atf := True; exit Check_For_Artefacts; end if; end loop Check_For_Artefacts; if Done and then not Options.Sources_Only and then Has_Atf then if Copy (Object) then for CU of CUs loop if CU.Kind not in S_Spec | S_Separate and then Atf.Has_Object_Code (CU.Index) then Copy_File (From => Atf.Object_Code (CU.Index), To => Lib_Dir); end if; end loop; end if; -- Install Ada .ali files (name the .ali -- against the spec file in case of minimal -- installation). if Copy (Dependency) then declare use GPR2.Project.Source.Artifact; Proj : GPR2.Project.View.Object; Satf : GPR2.Project.Source.Artifact.Object; begin if Options.All_Sources or else not Source.Has_Naming_Exception or else not Source.Has_Single_Unit or else not Source.Has_Other_Part then Satf := Atf; else Satf := Source.Other_Part.Source.Artifacts (Force_Spec => True); end if; if Project.Qualifier = K_Aggregate_Library then Proj := Project; else Proj := Source.View; end if; if Is_Ada (Source) then for CU of Source.Units loop if Source.Kind (CU.Index) not in S_Spec | S_Separate and then Atf.Has_Dependency (CU.Index) then Copy_File (From => Atf.Dependency (CU.Index), To => (if Proj.Kind = K_Library then ALI_Dir else Lib_Dir), File => Satf.Dependency.Simple_Name); -- The .ali has been copied, we now -- also want to create a file based on -- .ali for .ali if needed. if Source.Has_Other_Part then Copy_ALI_Other_Part (From => Atf.Dependency (CU.Index), To => (if Proj.Kind = K_Library then ALI_Dir else Lib_Dir), Source => Source); end if; end if; end loop; end if; if Atf.Has_Callgraph and then Atf.Callgraph.Exists then Copy_File (From => Atf.Callgraph, To => (if Proj.Kind = K_Library then ALI_Dir else Lib_Dir), File => Satf.Callgraph.Simple_Name); end if; if Atf.Has_Coverage and then Atf.Coverage.Exists then Copy_File (From => Atf.Coverage, To => (if Proj.Kind = K_Library then ALI_Dir else Lib_Dir), File => Satf.Coverage.Simple_Name); end if; end; end if; end if; end if; end Install_Project_Source; begin for Source of Project.Sources loop Install_Project_Source (Source); end loop; end Copy_Project_Sources; ----------------- -- Copy_Source -- ----------------- function Copy_Source (Source : GPR2.Project.Source.Object) return Boolean is Position : GPR2.Project.Source.Set.Cursor; Inserted : Boolean := False; begin Source_Copied.Insert (Source, Position, Inserted); if not Inserted or else not Is_Install_Active (Source.View) then return False; elsif not Copy (Process.Source) then return Inserted; end if; declare Art : constant GPR2.Project.Source.Artifact.Object := Source.Artifacts; begin Copy_File (From => (if Art.Preprocessed_Source.Exists then Art.Preprocessed_Source else Source.Path_Name), To => Sources_Dir, File => Source.Path_Name.Simple_Name); end; return True; end Copy_Source; begin if Has_Sources (Project) then -- Install the project and the extended projects if any Copy_Project_Sources (Project); end if; -- Copy library if Copy (Library) and then not Options.Sources_Only then if not Project.Is_Static_Library and then Project.Has_Library_Version and then Project.Library_Name /= Project.Library_Version_Filename.Name then if Windows_Target then -- No support for version, do a simple copy Copy_File (From => Project.Library_Directory, To => Lib_Dir, File => Project.Library_Filename.Name, Executable => True, Extract_Debug => Side_Debug); elsif Is_Windows_Host then -- On windows host, Library_Filename is generated, Copy_File (From => Project.Library_Filename, To => Lib_Dir, Executable => True, Extract_Debug => Side_Debug); else Copy_File (From => Project.Library_Version_Filename, To => Lib_Dir, Executable => True, Extract_Debug => Side_Debug); Copy_File (From => Path_Name.Compose (Lib_Dir, Project.Library_Filename.Name), To => Lib_Dir, File => Project.Library_Version_Filename.Simple_Name, From_Ver => Path_Name.Compose (Lib_Dir, Project.Library_Major_Version_Filename.Name), Sym_Link => True); end if; else Copy_File (From => Project.Library_Directory, To => Lib_Dir, File => Project.Library_Filename.Name, Executable => not Project.Is_Static_Library, Extract_Debug => Side_Debug and then not Project.Is_Static_Library); end if; -- On Windows copy the shared libraries into the bin directory -- for it to be found in the PATH when running executable. On non -- Windows platforms add a symlink into the lib directory. if not Project.Is_Static_Library and then not Options.No_Lib_Link then if Windows_Target then if Lib_Dir /= Exec_Dir then Copy_File (From => Lib_Dir, To => Exec_Dir, File => Project.Library_Filename.Name, Executable => True, Extract_Debug => False); end if; elsif Link_Lib_Dir /= Lib_Dir then pragma Warnings (Off, "this code can never be executed and has been deleted"); if Is_Windows_Host then Copy_File (From => Lib_Dir, To => Link_Lib_Dir, File => Project.Library_Filename.Name, Sym_Link => False); else Copy_File (From => Link_Lib_Dir, To => Lib_Dir, File => Project.Library_Filename.Name, Sym_Link => True); end if; pragma Warnings (On, "this code can never be executed and has been deleted"); -- Copy also the versioned library if any if not Is_Windows_Host and then Project.Has_Library_Version and then Project.Library_Filename.Name /= Project.Library_Version_Filename.Name then Copy_File (From => Link_Lib_Dir, To => Lib_Dir, File => Project.Library_Version_Filename.Name, From_Ver => Path_Name.Compose (Link_Lib_Dir, Project.Library_Major_Version_Filename.Name), Sym_Link => True); end if; end if; end if; end if; -- Copy executable(s) if Copy (Executable) and then not Options.Sources_Only then for Main of Project.Executables loop Copy_File (From => Main, To => Exec_Dir, Executable => True, Extract_Debug => Side_Debug); end loop; end if; -- Copy artifacts for E of Artifacts loop declare Destination : constant Filename_Type := Filename_Type (To_String (E.Destination)); Filename : constant Filename_Type := Filename_Type (To_String (E.Filename)); begin Copy_Artifacts (Path_Name.Compose (Project.Dir_Name, Filename), Path_Name.Create_Directory (Destination, Filename_Optional (-Prefix_Dir.V)), E.Required); end; end loop; end Copy_Files; -------------------- -- Create_Project -- -------------------- procedure Create_Project (Project : GPR2.Project.View.Object) is use type Ada.Containers.Count_Type; package Lang_Set is new Ada.Containers.Indefinite_Ordered_Sets (String, Strings.Less_Case_Insensitive, Strings.Equal_Case_Insensitive); Filename : constant String := Project_Dir.Dir_Name & String (Project.Path_Name.Base_Name) & ".gpr"; GPRinstall_Tag : constant String := "This project has been generated by GPRINSTALL"; Line : Unbounded_String; Languages : Lang_Set.Set; function "+" (Item : String) return Unbounded_String renames To_Unbounded_String; function "-" (Item : Unbounded_String) return String renames To_String; procedure Create_Packages; -- Create packages that are needed, currently Naming and part of -- Linker is generated for the installed project. procedure Create_Variables; -- Create global variables procedure Read_Project; -- Read project and set Content accordingly procedure With_External_Imports (Project : GPR2.Project.View.Object); -- Add all imports of externally built projects into install project -- imports. procedure Write_Project; -- Write content into project procedure Add_Empty_Line with Inline; function Naming_Case_Alternative (Project : GPR2.Project.View.Object) return String_Vector.Vector; -- Returns the naming case alternative for this project configuration function Linker_Case_Alternative (Proj : GPR2.Project.View.Object) return String_Vector.Vector; -- Returns the linker case alternative for this project configuration function Data_Attributes return String_Vector.Vector; -- Returns the attributes for the sources, objects and library function Get_Languages return Lang_Set.Set; -- Returns the list of languages function Get_Build_Line (Vars, Default : String) return String; -- Returns the build line for Var1 and possibly Var2 if not empty -- string. Default is the default build name. -------------------- -- Add_Empty_Line -- -------------------- procedure Add_Empty_Line is begin if Content.Element (Content.Last_Index) /= "" then Content.Append (""); end if; end Add_Empty_Line; --------------------- -- Create_Packages -- --------------------- procedure Create_Packages is procedure Create_Naming (Project : GPR2.Project.View.Object); -- Create the naming package procedure Create_Linker (Project : GPR2.Project.View.Object); -- Create the linker package if needed ------------------- -- Create_Linker -- ------------------- procedure Create_Linker (Project : GPR2.Project.View.Object) is begin Content.Append (" package Linker is"); Content.Append (" case BUILD is"); -- Attribute Linker_Options only if set Content.Append_Vector (Linker_Case_Alternative (Project)); Content.Append (" end case;"); Content.Append (" end Linker;"); Add_Empty_Line; end Create_Linker; ------------------- -- Create_Naming -- ------------------- procedure Create_Naming (Project : GPR2.Project.View.Object) is Found : Boolean := False; begin Content.Append (" package Naming is"); for A of Project.Attributes (Pack => P.Naming, With_Defaults => False, With_Config => False) loop if not A.Has_Index then Content.Append (" " & A.Image); Found := True; end if; end loop; if Found then Content.Append (""); end if; Content.Append (" case BUILD is"); Content.Append_Vector (Naming_Case_Alternative (Project)); Content.Append (" end case;"); Content.Append (" end Naming;"); Add_Empty_Line; end Create_Naming; begin Create_Naming (Project); Create_Linker (Project); end Create_Packages; ---------------------- -- Create_Variables -- ---------------------- procedure Create_Variables is Max_Len : Natural := 0; -- List of output types to avoid duplicate T : GPR2.Containers.Name_Set; procedure Create_Type (Typ : GPR2.Project.Typ.Object); -- Output type definition if not already created ----------------- -- Create_Type -- ----------------- procedure Create_Type (Typ : GPR2.Project.Typ.Object) is T_Name : constant Name_Type := Typ.Name.Text; begin if not T.Contains (T_Name) then Write_Str (" " & Typ.Image); Write_Eol; T.Insert (T_Name); end if; end Create_Type; Var_Has_Type : Boolean := False; begin -- Output types if any if Project.Has_Types then for Typ of Project.Types loop Create_Type (Typ); end loop; end if; if Project.Has_Variables then for Var of Project.Variables loop -- Compute variable max length Max_Len := Natural'Max (Max_Len, Var.Name.Text'Length); -- Output types used in variable if any if Var.Has_Type then Create_Type (Var.Typ); Var_Has_Type := True; end if; end loop; if Var_Has_Type then Write_Eol; end if; -- Finally output variables for Var of Project.Variables loop Write_Str (" " & Var.Image (Name_Len => Max_Len)); Write_Eol; end loop; end if; end Create_Variables; --------------------- -- Data_Attributes -- --------------------- function Data_Attributes return String_Vector.Vector is procedure Gen_Dir_Name (P : Param; Line : in out Unbounded_String); -- Generate dir name ------------------ -- Gen_Dir_Name -- ------------------ procedure Gen_Dir_Name (P : Param; Line : in out Unbounded_String) is begin if P.Default then -- This is the default value, add Dir_Name Line := Line & String (Dir_Name (Suffix => False)); -- Furthermore, if the build name is "default" do not output if -Options.Build_Name /= "default" then Line := Line & "." & (-Options.Build_Name); end if; end if; end Gen_Dir_Name; V : String_Vector.Vector; Line : Unbounded_String; Attr : GPR2.Project.Attribute.Object; Standalone : GPR2.Project.Standalone_Library_Kind; use type GPR2.Project.Standalone_Library_Kind; begin V.Append (" when """ & (-Options.Build_Name) & """ =>"); -- Project sources Line := +" for Source_Dirs use ("""; if Has_Sources (Project) then Line := Line & String (Sources_Dir (Build_Name => False).Relative_Path (From => Project_Dir).Name); Gen_Dir_Name (Sources_Subdir, Line); end if; Line := Line & """);"; V.Append (-Line); -- Project objects and/or library if Project.Is_Library then Line := +" for Library_Dir use """; else Line := +" for Object_Dir use """; end if; Line := Line & String (Lib_Dir (Build_Name => False).Relative_Path (From => Project_Dir).Name); Gen_Dir_Name (Lib_Subdir, Line); Line := Line & """;"; V.Append (-Line); if Project.Is_Library then -- If ALI are in a different location, set the corresponding -- attribute. if Lib_Dir /= ALI_Dir then Line := +" for Library_ALI_Dir use """; Line := Line & String (ALI_Dir (Build_Name => False).Relative_Path (From => Project_Dir).Name); Gen_Dir_Name (ALI_Subdir, Line); Line := Line & """;"; V.Append (-Line); end if; V.Append (" for Library_Kind use """ & String (Project.Library_Kind) & """;"); Standalone := Project.Library_Standalone; if Standalone /= GPR2.Project.No then if not Project.Is_Static_Library then V.Append (" for Library_Standalone use """ & Characters.Handling.To_Lower (Standalone'Image) & """;"); end if; -- And then generates the interfaces declare First : Boolean := True; begin if Project.Check_Attribute (A.Library_Interface, Result => Attr) then Line := +" for Library_Interface use ("; for V of Attr.Values loop if not First then Append (Line, ", "); end if; Append (Line, Quote (V.Text)); First := False; end loop; elsif Project.Check_Attribute (A.Interfaces, Result => Attr) then Line := +" for Interfaces use ("; for V of Attr.Values loop if not First then Append (Line, ", "); end if; Append (Line, Quote (V.Text)); First := False; end loop; else Line := +" for library_Interfaces use ("; for Source of Project.Sources (Interface_Only => True) loop if Source.Has_Units then for CU of Source.Units loop if CU.Kind in S_Spec | S_Spec_Only | S_Body_Only then if not First then Append (Line, ", "); end if; Append (Line, Quote (String (CU.Name))); First := False; end if; end loop; end if; end loop; end if; end; Append (Line, ");"); V.Append (-Line); end if; end if; return V; end Data_Attributes; -------------------- -- Get_Build_Line -- -------------------- function Get_Build_Line (Vars, Default : String) return String is use Strings.Fixed; Variables : String_Split.Slice_Set; Line : Unbounded_String; begin Line := +" BUILD : BUILD_KIND := "; if not Options.No_Build_Var then String_Split.Create (Variables, Vars, ","); if Vars = "" then -- No variable specified, use default value Line := Line & "external("""; Line := Line & Characters.Handling.To_Upper (String (Dir_Name (Suffix => False))); Line := Line & "_BUILD"", "; else for K in 1 .. String_Split.Slice_Count (Variables) loop Line := Line & "external("""; Line := Line & String_Split.Slice (Variables, K) & """, "; end loop; end if; end if; Line := Line & '"' & Default & '"'; if not Options.No_Build_Var then Line := Line & (+(Natural (String_Split.Slice_Count (Variables)) * ')')); end if; Line := Line & ';'; return -Line; end Get_Build_Line; ------------------- -- Get_Languages -- ------------------- function Get_Languages return Lang_Set.Set is Langs : Lang_Set.Set; procedure For_Project (Project : GPR2.Project.View.Object); -- Add languages for the given project ----------------- -- For_Project -- ----------------- procedure For_Project (Project : GPR2.Project.View.Object) is use GPR2.Project; package A renames GPR2.Project.Registry.Attribute; package P renames GPR2.Project.Registry.Pack; Attr : GPR2.Project.Attribute.Object; begin if Project.Has_Languages then for Lang of Project.Languages loop if Project.Tree.Has_Configuration then declare C : constant GPR2.Project.View.Object := Project.Tree.Configuration.Corresponding_View; begin -- Compiler driver defined in configuration if (C.Has_Package (P.Compiler) and then C.Check_Attribute (A.Compiler.Driver, Attribute_Index.Create (Lang.Text), Result => Attr) and then Attr.Value.Text /= "") -- Or defined in the project itself or else (Project.Has_Package (P.Compiler) and then Project.Check_Attribute (A.Compiler.Driver, Attribute_Index.Create (Lang.Text), Result => Attr)) then Langs.Include (Lang.Text); end if; end; end if; end loop; end if; end For_Project; begin -- First adds language for the main project For_Project (Project); -- If we are dealing with an aggregate library, adds the languages -- from all aggregated projects. if Project.Qualifier = K_Aggregate_Library then for Agg of Project.Aggregated loop For_Project (Agg); end loop; end if; return Langs; end Get_Languages; ----------------------------- -- Linker_Case_Alternative -- ----------------------------- function Linker_Case_Alternative (Proj : GPR2.Project.View.Object) return String_Vector.Vector is procedure Linker_For (View : GPR2.Project.View.Object); -- Handle the linker options for this package procedure Append (Attribute : GPR2.Project.Attribute.Object); -- Add values if any procedure Opts_Append (Opt : String); -- Add Opt into Opts only if not added before procedure Append_Imported_External_Libraries (Project : GPR2.Project.View.Object); -- Add the externally built libraries without sources (referencing -- system libraries for example). Seen : GPR2.Containers.Value_Set; -- Records the attribute generated to avoid duplicate when -- handling aggregated projects. R : String_Vector.Vector; Opts : String_Vector.Vector; ------------ -- Append -- ------------ procedure Append (Attribute : GPR2.Project.Attribute.Object) is begin for V of Attribute.Values loop if V.Text /= "" then Opts_Append (V.Text); end if; end loop; end Append; ---------------------------------------- -- Append_Imported_External_Libraries -- ---------------------------------------- procedure Append_Imported_External_Libraries (Project : GPR2.Project.View.Object) is begin if Project.Has_Imports then for L of Project.Imports (Recursive => True) loop if L.Kind = K_Library and then L.Is_Externally_Built and then not L.Has_Sources then Opts_Append ("-L" & L.Library_Directory.Value); Opts_Append ("-l" & String (L.Library_Name)); end if; end loop; end if; end Append_Imported_External_Libraries; ---------------- -- Linker_For -- ---------------- procedure Linker_For (View : GPR2.Project.View.Object) is begin if View.Has_Attribute (A.Linker.Linker_Options) then Append (View.Attribute (A.Linker.Linker_Options)); end if; end Linker_For; ----------------- -- Opts_Append -- ----------------- procedure Opts_Append (Opt : String) is Position : GPR2.Containers.Value_Type_Set.Cursor; Inserted : Boolean; begin Seen.Insert (Opt, Position, Inserted); if Inserted then Opts.Append (Opt); end if; end Opts_Append; begin R.Append (" when """ & (-Options.Build_Name) & """ =>"); Linker_For (Project); if Proj.Qualifier = K_Aggregate_Library then for Aggregated of Proj.Aggregated loop Linker_For (Aggregated); Append_Imported_External_Libraries (Aggregated); end loop; end if; Append_Imported_External_Libraries (Project); -- Append Library_Options to Opts list if Proj.Is_Library then declare Library_Options : constant GPR2.Project.Attribute.Object := Proj.Attribute (A.Library_Options); begin if Library_Options.Is_Defined then for Value of Library_Options.Values loop Opts_Append (Value.Text); end loop; end if; end; end if; if Opts.Length = 0 then -- No linker alternative found, add null statement R.Append (" null;"); else declare O_List : Unbounded_String; begin for O of Opts loop if O_List /= Null_Unbounded_String then Append (O_List, ", "); end if; Append (O_List, '"' & O & '"'); end loop; R.Append (" for Linker_Options use (" & To_String (O_List) & ");"); end; end if; return R; end Linker_Case_Alternative; ----------------------------- -- Naming_Case_Alternative -- ----------------------------- function Naming_Case_Alternative (Project : GPR2.Project.View.Object) return String_Vector.Vector is procedure Naming_For (View : GPR2.Project.View.Object); -- Handle the naming scheme for this view Seen : GPR2.Containers.Name_Set; -- Records the attribute generated to avoid duplicate when -- handling aggregated projects. V : String_Vector.Vector; -- Contains the final result returned function Is_Language_Active (Lang : String) return Boolean is (Languages.Contains ((Characters.Handling.To_Lower (Lang)))); -- Returns True if Lang is active in the installed project ---------------- -- Naming_For -- ---------------- procedure Naming_For (View : GPR2.Project.View.Object) is Found : Boolean := False; begin if View.Has_Package (P.Naming, With_Defaults => False, With_Config => False) then -- Check all associative attributes for Att of View.Attributes (Pack => P.Naming, With_Defaults => False, With_Config => False) loop if Att.Has_Index then if (Att.Name.Id /= A.Naming.Body_N or else not Excluded_Naming.Contains (Name_Type (Att.Index.Text))) and then ((Att.Name.Id not in A.Naming.Spec_Suffix | A.Naming.Body_Suffix | A.Naming.Separate_Suffix) or else Is_Language_Active (Att.Index.Text)) then declare Decl : constant String := Att.Image; Pos : GPR2.Containers.Name_Type_Set.Cursor; OK : Boolean; begin Seen.Insert (Name_Type (Decl), Pos, OK); if OK then V.Append (" " & Decl); Found := True; end if; end; end if; end if; end loop; end if; if not Found then V.Append (" null;"); end if; end Naming_For; begin V.Append (" when """ & (-Options.Build_Name) & """ =>"); Naming_For (Project); if Project.Qualifier = K_Aggregate_Library then for Agg of Project.Aggregated loop Naming_For (Agg); end loop; end if; return V; end Naming_Case_Alternative; ------------------ -- Read_Project -- ------------------ procedure Read_Project is Max_Buffer : constant := 1_024; File : File_Type; Buffer : String (1 .. Max_Buffer); Last : Natural; begin Open (File, In_File, Filename); while not End_Of_File (File) loop declare L : Unbounded_String; begin loop Get_Line (File, Buffer, Last); Append (L, Buffer (1 .. Last)); exit when Last < Max_Buffer or else End_Of_Line (File); end loop; Content.Append (To_String (L)); end; end loop; Close (File); end Read_Project; --------------------------- -- With_External_Imports -- --------------------------- procedure With_External_Imports (Project : GPR2.Project.View.Object) is begin for L of Project.Imports (Recursive => True) loop if L.Has_Sources and then L.Is_Externally_Built then Content.Append ("with """ & String (L.Path_Name.Base_Name) & """;"); end if; end loop; end With_External_Imports; ------------------- -- Write_Project -- ------------------- procedure Write_Project is F : File_Access := Standard_Output; File : aliased File_Type; begin if not Options.Dry_Run then if not Project_Dir.Exists then Directories.Create_Path (Project_Dir.Value); end if; Create (File, Out_File, Filename); F := File'Unchecked_Access; end if; for Line of Content loop Put_Line (F.all, Line); end loop; if not Options.Dry_Run then Close (File); end if; end Write_Project; type Section_Kind is (Top, Naming, Linker); Project_Exists : constant Boolean := Directories.Exists (Filename); Current_Section : Section_Kind := Top; Pos : String_Vector.Cursor; Generated : Boolean := False; begin -- Set-up all languages used by the project tree Languages := Get_Languages; -- Check if the tool set has been found and we have at least one -- language defined. if Languages.Length = 0 then raise GPRinstall_Error with "cannot find toolchain for the project " & String (Project.Name) & ", no language found, aborting"; end if; if Options.Dry_Run or else Options.Verbose then New_Line; Put ("Project "); Put (Filename); if Options.Dry_Run then Put_Line (" would be installed"); else Put_Line (" installed"); end if; New_Line; end if; -- If project exists, read it and check the generated status if Project_Exists then Read_Project; -- First check that this project has been generated by gprbuild, -- if not exit with an error as we cannot modify a project created -- manually and we do not want to overwrite it. Pos := Content.First; Check_Generated_Status : while String_Vector.Has_Element (Pos) loop if Strings.Fixed.Index (String_Vector.Element (Pos), GPRinstall_Tag) /= 0 then Generated := True; exit Check_Generated_Status; end if; String_Vector.Next (Pos); end loop Check_Generated_Status; if not Generated and then not Options.Force_Installations then raise GPRinstall_Error with "non gprinstall project file " & Filename & " exists, use -f to overwrite"; end if; end if; if Project_Exists and then Generated then if not Has_Sources (Project) then -- Nothing else to do in this case return; end if; if Options.Verbose then Put_Line ("project file exists, merging new build"); end if; -- Do merging for new build, we need to add an entry into the -- BUILD_KIND type and a corresponding case entry in the naming -- and Linker package. The variables need also to be updated. Parse_Content : while String_Vector.Has_Element (Pos) loop declare use Ada.Strings; procedure Insert_Move_After (Pos : in out String_Vector.Cursor; V : String_Vector.Vector); -- Insert V into Content before Pos and return Post to be -- the item after the last inserted. ----------------------- -- Insert_Move_After -- ----------------------- procedure Insert_Move_After (Pos : in out String_Vector.Cursor; V : String_Vector.Vector) is C : constant Ada.Containers.Count_Type := V.Length; P : constant String_Vector.Extended_Index := String_Vector.To_Index (Pos); begin String_Vector.Next (Pos); Content.Insert_Vector (Pos, V); Pos := Content.To_Cursor (P + String_Vector.Extended_Index (C)); end Insert_Move_After; BN : constant String := -Options.Build_Name; Line : constant String := String_Vector.Element (Pos); P, L : Natural; begin if Fixed.Index (Line, "type BUILD_KIND is (") /= 0 then -- This is the "type BUILD_KIND" line, add new build name -- First check if the current build name already exists if Fixed.Index (Line, """" & BN & """") = 0 then -- Get end of line P := Strings.Fixed.Index (Line, ");"); if P = 0 then raise GPRinstall_Error with "cannot parse the BUILD_KIND line"; else Content.Replace_Element (Pos, Line (Line'First .. P - 1) & ", """ & BN & """);"); end if; end if; elsif Fixed.Index (Line, ":= external(") /= 0 then -- This is the BUILD line, get build vars declare Default : Unbounded_String; begin -- Get default value L := Fixed.Index (Line, """", Going => Strings.Backward); P := Fixed.Index (Line (Line'First .. L - 1), """", Going => Strings.Backward); Default := +Line (P + 1 .. L - 1); Content.Replace_Element (Pos, Get_Build_Line (-Options.Build_Vars, -Default)); end; elsif Fixed.Index (Line, "package Naming is") /= 0 then Current_Section := Naming; elsif Fixed.Index (Line, "package Linker is") /= 0 then Current_Section := Linker; elsif Fixed.Index (Line, "case BUILD is") /= 0 then -- Add new case section for the new build name case Current_Section is when Naming => Insert_Move_After (Pos, Naming_Case_Alternative (Project)); when Linker => Insert_Move_After (Pos, Linker_Case_Alternative (Project)); when Top => -- For the Sources/Lib attributes Insert_Move_After (Pos, Data_Attributes); end case; elsif Fixed.Index (Line, "when """ & BN & """ =>") /= 0 then -- Found a when with the current build name, this is a -- previous install overwritten by this one. Remove this -- section. Note that this removes sections from all -- packages Naming and Linker, and from project level -- case alternative. Count_And_Delete : declare function End_When (L : String) return Boolean; -- Return True if L is the end of a when alternative -------------- -- End_When -- -------------- function End_When (L : String) return Boolean is P : constant Natural := Strings.Fixed.Index_Non_Blank (L); Len : constant Natural := L'Last; begin return P > 0 and then ((P + 4 <= Len and then L (P .. P + 4) = "when ") or else (P + 8 <= Len and then L (P .. P + 8) = "end case;")); end End_When; I : constant String_Vector.Extended_Index := String_Vector.To_Index (Pos); P : String_Vector.Extended_Index := String_Vector.To_Index (Pos); N : Ada.Containers.Count_Type := 0; begin -- The number of line to delete are from Pos to the -- first line starting with a "when". loop N := N + 1; P := P + 1; exit when End_When (Content.Element (P)); end loop; Content.Delete (Pos, N); -- Then reset Pos to I (previous Pos index) Pos := Content.To_Cursor (I); end Count_And_Delete; else Check_Vars : declare Assign : constant Natural := Fixed.Index (Line, " := "); begin -- Check if line is a variable definition, and if so -- update the value. if Assign > 0 then for V of Project.Variables loop declare Name : constant String := String (V.Name.Text); begin if Fixed.Index (Line, ' ' & Name & ' ') in 1 .. Assign - 1 then Content.Replace_Element (Pos, " " & V.Image); end if; end; end loop; end if; end Check_Vars; end if; end; String_Vector.Next (Pos); end loop Parse_Content; else -- Project does not exist, or it exists, was not generated by -- gprinstall and -f used. In this case it will be overwritten by -- a generated project. Content.Clear; -- Tag project as generated by gprbuild Content.Append ("-- " & GPRinstall_Tag & ' ' & Version.Long_Value); Add_Empty_Line; if Project.Qualifier = K_Aggregate_Library then for V of Project.Aggregated loop With_External_Imports (V); end loop; Add_Empty_Line; elsif Project.Has_Imports then -- Handle with clauses, generate a with clauses only for -- project bringing some visibility to sources. No need -- for doing this for aggregate projects. for L of Project.Imports loop if L.Has_Sources and then Is_Install_Active (L) then Content.Append ("with """ & String (L.Path_Name.Base_Name) & """;"); end if; end loop; With_External_Imports (Project); -- Also add with for all limited with projects for L of Project.Limited_Imports loop if Is_Install_Active (L) then Content.Append ("with """ & String (L.Path_Name.Base_Name) & """;"); end if; end loop; Add_Empty_Line; end if; -- Project name if Project.Is_Library then Line := +"library "; else if Has_Sources (Project) then Line := +"standard "; else Line := +"abstract "; end if; end if; Line := Line & "project "; Line := Line & String (Project.Name); Line := Line & " is"; Content.Append (-Line); if Has_Sources (Project) or else Project.Is_Library then -- BUILD variable Content.Append (" type BUILD_KIND is (""" & (-Options.Build_Name) & """);"); Line := +Get_Build_Line (Vars => -Options.Build_Vars, Default => -Options.Build_Name); Content.Append (-Line); -- Add languages, for an aggregate library we want all unique -- languages from all aggregated libraries. if Has_Sources (Project) then Add_Empty_Line; declare Lang : Unbounded_String; First : Boolean := True; begin for L of Languages loop if not First then Append (Lang, ", "); end if; Append (Lang, '"' & L & '"'); First := False; end loop; Content.Append (" for Languages use (" & To_String (Lang) & ");"); end; end if; -- Build_Suffix used to avoid .default as suffix Add_Empty_Line; Content.Append (" case BUILD is"); Content.Append_Vector (Data_Attributes); Content.Append (" end case;"); Add_Empty_Line; -- Library Name if Project.Is_Library then Content.Append (" for Library_Name use """ & String (Project.Library_Name) & """;"); -- Issue the Library_Version only if needed if not Project.Is_Static_Library and then Project.Has_Library_Version and then Project.Library_Filename.Name /= Project.Library_Version_Filename.Name then Content.Append (" for Library_Version use """ & String (Project.Library_Version_Filename.Name) & """;"); end if; end if; -- Packages if Has_Sources (Project) then Add_Empty_Line; Create_Packages; end if; -- Set as not installable Add_Empty_Line; Content.Append (" package Install is"); Content.Append (" for Active use ""False"";"); Content.Append (" end Install;"); -- Externally Built if not Options.Sources_Only then Add_Empty_Line; Content.Append (" for Externally_Built use ""True"";"); end if; else -- This is an abstract project Content.Append (" for Source_Dirs use ();"); end if; -- Variables Add_Empty_Line; Create_Variables; -- Close project Content.Append ("end " & String (Project.Name) & ";"); end if; -- Write new project if needed Write_Project; if not Options.Dry_Run and then Options.Install_Manifest then -- Add project file to manifest Add_To_Manifest (Path_Name.Create_File (Filename_Type (Filename))); end if; end Create_Project; -------------- -- Dir_Name -- -------------- function Dir_Name (Suffix : Boolean := True) return Filename_Type is function Get_Suffix return Filename_Optional; -- Returns a suffix if needed ---------------- -- Get_Suffix -- ---------------- function Get_Suffix return Filename_Optional is begin -- .default is always omitted from the directory name if Suffix and then -Options.Build_Name /= "default" then return Filename_Type ('.' & (-Options.Build_Name)); else return No_Filename; end if; end Get_Suffix; begin return Project.Path_Name.Base_Filename & Get_Suffix; end Dir_Name; -------------- -- Exec_Dir -- -------------- function Exec_Dir return Path_Name.Object is (Prefix_For_Dir (-Exec_Subdir.V)); ----------------- -- Has_Sources -- ----------------- function Has_Sources (Project : GPR2.Project.View.Object) return Boolean is begin return Project.Has_Sources or else Project.Qualifier = K_Aggregate_Library; end Has_Sources; ----------------------- -- Is_Install_Active -- ----------------------- function Is_Install_Active (Project : GPR2.Project.View.Object) return Boolean is begin if Project.Has_Package (P.Install) then for V of Project.Attributes (Pack => P.Install) loop if V.Name.Id = A.Install.Active then return Characters.Handling.To_Lower (V.Value.Text) /= "false"; end if; end loop; end if; -- If not defined, the default is active return True; end Is_Install_Active; ------------- -- Lib_Dir -- ------------- function Lib_Dir (Build_Name : Boolean := True) return Path_Name.Object is begin return Build_Subdir (Lib_Subdir, Build_Name); end Lib_Dir; ------------------ -- Link_Lib_Dir -- ------------------ function Link_Lib_Dir return Path_Name.Object is (Prefix_For_Dir (-Link_Lib_Subdir.V)); ------------------------- -- Open_Check_Manifest -- ------------------------- procedure Open_Check_Manifest (File : out Text_IO.File_Type; Current_Line : out Text_IO.Count) is Dir : constant Path_Name.Object := Path_Name.Compose (Project_Dir, "manifests"); M_File : constant Path_Name.Object := Path_Name.Create_File (Filename_Type (-Install_Name.V), Filename_Optional (Dir.Value)); Name : constant String := String (M_File.Value); Prj_Sig : constant String := Project.Path_Name.Content_MD5; Buf : String (1 .. 128); Last : Natural; begin -- Check whether the manifest does not exist in this case if Directories.Exists (Name) then -- If this manifest is the same of the current aggregate -- one, do not try to reopen it. if not Is_Open (Agg_Manifest) or else OS_Lib.Normalize_Pathname (Text_IO.Name (Agg_Manifest), Case_Sensitive => False) /= OS_Lib.Normalize_Pathname (Name, Case_Sensitive => False) then Open (File, In_File, Name); if not End_Of_File (File) then Get_Line (File, Buf, Last); if Last >= Message_Digest'Length and then (Buf (1 .. 2) /= Sig_Line or else Buf (3 .. Message_Digest'Last + 2) /= Prj_Sig) and then Install_Name.Default and then Install_Project then Put_Line ("Project file " & String (Project.Path_Name.Simple_Name) & " is different from the one currently installed."); Put_Line ("Either:"); Put_Line (" - uninstall first using --uninstall option"); Put_Line (" - install under another name, use --install-name"); Put_Line (" - force installation under the same name, " & "use --install-name=" & (-Install_Name.V)); raise GPRinstall_Error_No_Message; end if; end if; Reset (File, Append_File); Current_Line := Line (File); end if; else Directories.Create_Path (Dir.Value); Create (File, Out_File, Name); Current_Line := 1; Put_Line (File, Sig_Line & Prj_Sig); end if; exception when Text_IO.Use_Error => raise GPRinstall_Error with "cannot open or create the manifest file " & (-Project_Subdir.V) & (-Install_Name.V) & ", check permissions on this location"; end Open_Check_Manifest; ----------------- -- Project_Dir -- ----------------- function Project_Dir return Path_Name.Object is (Prefix_For_Dir (-Project_Subdir.V)); ------------------------ -- Rollback_Manifests -- ------------------------ procedure Rollback_Manifests is Content : String_Vector.Vector; procedure Rollback_Manifest (File : in out Text_IO.File_Type; Line : Text_IO.Count); ----------------------- -- Rollback_Manifest -- ----------------------- procedure Rollback_Manifest (File : in out Text_IO.File_Type; Line : Text_IO.Count) is use type Ada.Containers.Count_Type; Dir : constant String := Directories.Containing_Directory (Name (File)) & DS; Buffer : String (1 .. 4_096); Last : Natural; begin -- Set manifest file in Read mode Reset (File, Text_IO.In_File); while not End_Of_File (File) loop Get_Line (File, Buffer, Last); if Text_IO.Line (File) = 2 or else Text_IO.Line (File) < Line then -- Record file to be kept in manifest Content.Append (Buffer (1 .. Last)); else -- Delete file declare Filename : constant String := Dir & Buffer (GNAT.MD5.Message_Digest'Length + 2 .. Last); Unused : Boolean; begin OS_Lib.Delete_File (Filename, Unused); Delete_Empty_Directory (-Prefix_Dir.V, Directories.Containing_Directory (Filename)); end; end if; end loop; -- There is nothing left in the manifest file (only the signature -- line), remove it, otherwise we create the new manifest file -- containing only the previous content. if Content.Length = 1 then declare Manifest_Filename : constant String := Name (File); begin Delete (File); -- Delete manifest directories if empty Delete_Empty_Directory (-Prefix_Dir.V, Directories.Containing_Directory (Manifest_Filename)); end; else -- Set manifest file back to Write mode Reset (File, Text_IO.Out_File); for C of Content loop Text_IO.Put_Line (File, C); end loop; Close (File); end if; end Rollback_Manifest; begin if Is_Open (Man) then Rollback_Manifest (Man, Line_Manifest); end if; if Is_Open (Agg_Manifest) then Rollback_Manifest (Agg_Manifest, Line_Agg_Manifest); end if; end Rollback_Manifests; ----------------- -- Sources_Dir -- ----------------- function Sources_Dir (Build_Name : Boolean := True) return Path_Name.Object is begin return Build_Subdir (Sources_Subdir, Build_Name); end Sources_Dir; Is_Project_To_Install : Boolean; -- Whether the project is to be installed begin -- Empty Content Content.Delete_First (Count => Ada.Containers.Count_Type'Last); -- First look for the Install package and set up the local values -- accordingly. Check_Install_Package; -- The default install name is the name of the project without -- extension. if Install_Name.Default then Install_Name.V := To_Unbounded_String (String (Project.Path_Name.Base_Name)); end if; -- Skip non-active project, note that externally built project must be -- installed. Is_Project_To_Install := Active and then (Project.Has_Sources or else Project.Has_Attribute (A.Main) or else Project.Is_Externally_Built); -- If we have an aggregate project we just install separately all -- aggregated projects. if Project.Qualifier = K_Aggregate then -- If this is the main project and is an aggregate project, create -- the corresponding manifest. if Project = Tree.Root_Project and then Tree.Root_Project.Qualifier = K_Aggregate and then Options.Install_Manifest then Open_Check_Manifest (Agg_Manifest, Line_Agg_Manifest); end if; for Agg of Project.Aggregated (Recursive => False) loop Process (Tree, Agg, Options); end loop; -- Nothing more to do for an aggregate project return; end if; if not Installed.Contains (Project) then Installed.Insert (Project); if Options.Verbosity > Quiet then if Is_Project_To_Install then Put ("Install"); elsif Options.Verbose then Put ("Skip"); end if; if Is_Project_To_Install or else Options.Verbose then Put (" project " & String (Project.Name)); if -Options.Build_Name /= "default" then Put (" - " & (-Options.Build_Name)); end if; end if; if not Is_Project_To_Install and then Options.Verbose then Put (" (not active)"); end if; if Is_Project_To_Install or else Options.Verbose then New_Line; end if; end if; -- If this is not an active project, just return now if not Is_Project_To_Install then return; end if; if Project.Has_Mains and then Project.Mains.Is_Empty then Util.Output_Messages (Options); GPRtools.Util.Fail_Program ("problems with main sources"); end if; -- What should be copied ? Copy := (Source => For_Dev, Object => For_Dev and then not Project.Has_Mains and then Project.Qualifier /= K_Library and then Project.Qualifier /= K_Aggregate_Library and then Project.Kind /= K_Library, Dependency => For_Dev and then not Project.Has_Mains, Library => Project.Is_Library and then (not Project.Is_Static_Library or else For_Dev), Executable => Project.Has_Mains); if Copy = (Items => False) then Put_Line ("Nothing to be copied in mode " & (if For_Dev then "developer" else "usage") & " for this project"); end if; -- Copy all files from the project Copy_Files; -- A project file is only needed in developer mode if For_Dev and then Install_Project then Create_Project (Project); end if; -- Add manifest into the main aggregate project manifest if Is_Open (Man) then if Is_Open (Agg_Manifest) then declare Man_Dir : constant Path_Name.Object := Path_Name.Create_Directory ("manifests", Filename_Type (Project_Dir.Value)); Filename : constant Path_Name.Object := Path_Name.Create_File (Filename_Type (Directories.Simple_Name (Name (Man))), Filename_Type (Man_Dir.Value)); begin Close (Man); Add_To_Manifest (Filename, Aggregate_Only => True); end; else Close (Man); end if; end if; -- Handle all projects recursively if needed if Options.Recursive and then Project.Has_Imports then for P of Project.Imports loop Process (Tree, P, Options); end loop; -- Also install all limited with projects for P of Project.Limited_Imports loop Process (Tree, P, Options); end loop; end if; end if; end Process; procedure Process (Tree : GPR2.Project.Tree.Object; Options : GPRinstall.Options.Object) is begin Process (Tree, Tree.Root_Project, Options); end Process; --------------- -- Write_Eol -- --------------- procedure Write_Eol is begin Content.Append (New_Item => (Buffer (1 .. Buffer_Last))); Buffer_Last := 0; end Write_Eol; --------------- -- Write_Str -- --------------- procedure Write_Str (S : String) is begin while Buffer_Last + S'Length > Buffer'Last loop Double_Buffer; end loop; Buffer (Buffer_Last + 1 .. Buffer_Last + S'Length) := S; Buffer_Last := Buffer_Last + S'Length; end Write_Str; end GPRinstall.Install;