--  dh_ada_library, helper for Ada libraries Debian maintainers
--
--  Copyright (C) 2012-2014 Nicolas Boulenguez <nicolas@debian.org>
--
--  This program is free software: you can redistribute it and/or
--  modify it under the terms of the GNU General Public License as
--  published by the Free Software Foundation, either version 3 of the
--  License, or (at your option) any later version.
--  This program is distributed in the hope that it will be useful, but
--  WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY 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
--  along with this program. If not, see <http://www.gnu.org/licenses/>.

with Ada.Directories;

with GNAT.OS_Lib;

with Csets;  pragma Elaborate_All (Csets);  --  gnatvsn
with Namet;                                 --  gnatvsn
with Sinput.P;
with Snames; pragma Elaborate_All (Snames); --  gnatvsn
with Prj.Conf;
with Prj.Err;
with Prj.Ext;
with Prj.Part;
with Prj.Tree;
with Prj.Util;

package body Projects is

   Default_Cgpr : constant String := "/usr/share/dh_ada_library/default_cgpr";

   use type GNAT.OS_Lib.String_Access;
   use type Namet.Name_Id;
   use type Namet.Path_Name_Type;
   use type Prj.Language_Ptr;
   use type Prj.Lib_Kind;
   use type Prj.Naming_Exception_Type;
   use type Prj.Project_Id;
   use type Prj.Project_List;
   use type Prj.Project_Tree_Ref;
   use type Prj.Source_Kind;
   use type Prj.Source_Id;
   use type Prj.String_List_Id;
   use type Prj.Tree.Project_Node_Id;
   use type Prj.Variable_Kind;

   ----------------------------------------------------------------------

   function Externally_Built
     (Project : in Project_Record)
     return Boolean
   is
   begin
      return Project.Project_Id.all.Externally_Built;
   end Externally_Built;

   overriding procedure Finalize
     (Object : in out Project_Record)
   is
   begin
      if Object.Project_Tree_Ref /= Prj.No_Project_Tree then
         Prj.Free (Object.Project_Tree_Ref);
      end if;
   end Finalize;

   function Dynamic
     (Project : in Project_Record)
     return Boolean
   is
   begin
      case Project.Project_Id.all.Library_Kind is
         when Prj.Dynamic | Prj.Relocatable =>
            return True;
         when Prj.Static =>
            return False;
      end case;
   end Dynamic;

   function Is_Library
     (Project : in Project_Record)
     return Boolean
   is
   begin
      return Project.Project_Id.all.Library;
   end Is_Library;

   procedure Iterate_On_Ali_Files
     (Project : in Project_Record;
      Process : not null access procedure (Path : in String))
   is
      Ali_Dir      : Namet.Path_Name_Type;
      Language_Ptr : Prj.Language_Ptr;
      Source_Id    : Prj.Source_Id;
   begin
      --  Optional Library_ALI_Dir attribute defaults to Library_Dir.
      Ali_Dir := Project.Project_Id.all.Library_ALI_Dir.Name;
      if Ali_Dir = Namet.No_Path then
         Ali_Dir := Project.Project_Id.all.Library_Dir.Name;
      end if;
      --  Find the Ada language in the languages linked list.
      Language_Ptr := Project.Project_Id.all.Languages;
      loop
         if Language_Ptr = Prj.No_Language_Index then
            raise No_Ada_Sources;
         elsif Language_Ptr.all.Name = Snames.Name_Ada then
            exit;
         end if;
         Language_Ptr := Language_Ptr.all.Next;
      end loop;
      --  Iterate on specs or bodies without specs, not subunits.
      Source_Id := Language_Ptr.all.First_Source;
      while Source_Id /= Prj.No_Source loop
         --  Separate bodies have no Spec, Impl or ALI file.
         --  ALI files are named after the body file if any, else
         --  after the specification file.
         if Source_Id.all.Kind = Prj.Impl
           or (Source_Id.all.Kind = Prj.Spec
                 and Prj.Other_Part (Source_Id) = Prj.No_Source)
         then
            declare
               Name : String := Ada.Directories.Simple_Name
                 (Namet.Get_Name_String (Source_Id.all.Path.Name));
            begin
               pragma Assert (Name (Name'Last - 3 .. Name'Last) = ".ads"
                                or Name (Name'Last - 3 .. Name'Last) = ".adb");
               Name (Name'Last - 1 .. Name'Last) := "li";
               Process.all (Namet.Get_Name_String (Ali_Dir) & '/' & Name);
            end;
         end if;
         Source_Id := Source_Id.all.Next_In_Lang;
      end loop;
   end Iterate_On_Ali_Files;

   procedure Iterate_On_Imported_Projects
     (Project : in Project_Record;
      Process : not null access procedure
        (Imported_Full_File_Name : in String;
         Imported_Library_Name   : in String))
   is
      Project_List : Prj.Project_List;
      Project_Id   : Prj.Project_Id;
   begin
      Project_List := Project.Project_Id.all.Imported_Projects;
      while Project_List /= null loop
         Project_Id := Project_List.all.Project;
         if Project_Id.all.Library then
            Process.all (Namet.Get_Name_String (Project_Id.all.Path.Name),
                         Namet.Get_Name_String (Project_Id.all.Library_Name));
         else
            Process.all (Namet.Get_Name_String (Project_Id.all.Name), "");
         end if;
         Project_List := Project_List.all.Next;
      end loop;
   end Iterate_On_Imported_Projects;

   procedure Iterate_On_Library_Options
     (Project : in Project_Record;
      Process : not null access procedure (Option : in String))
   is
      Lib_Opts_Attrs : constant array (Positive range <>) of Namet.Name_Id
        := (Snames.Name_Leading_Library_Options,
            Snames.Name_Library_Options);
      Variable_Value : Prj.Variable_Value;
      String_List_Id : Prj.String_List_Id;
      Shared : constant Prj.Shared_Project_Tree_Data_Access
        := Project.Project_Tree_Ref.all.Shared;
   begin
      for Attribute_Name of Lib_Opts_Attrs loop
         Variable_Value := Prj.Util.Value_Of
           (Variable_Name => Attribute_Name,
            In_Variables  => Project.Project_Id.all.Decl.Attributes,
            Shared        => Shared);
         if not Variable_Value.Default then
            pragma Assert (Variable_Value.Project = Project.Project_Id);
            pragma Assert (Variable_Value.Kind = Prj.List);
            String_List_Id := Variable_Value.Values;
            while String_List_Id /= Prj.Nil_String loop
               declare
                  String_Element : constant Prj.String_Element
                    := Shared.all.String_Elements.Table.all (String_List_Id);
               begin
                  Process.all (Namet.Get_Name_String (String_Element.Value));
                  String_List_Id := String_Element.Next;
               end;
            end loop;
         end if;
      end loop;
   end Iterate_On_Library_Options;

   procedure Iterate_On_Naming_Exceptions
     (Project : in Project_Record;
      Process : not null access procedure (Unit    : in String;
                                           File    : in String;
                                           Is_Body : in Boolean))
   is
      Source_Iterator : Prj.Source_Iterator;
      Source_Id       : Prj.Source_Id;
   begin
      Source_Iterator := Prj.For_Each_Source (Project.Project_Tree_Ref,
                                              Project.Project_Id);
      loop
         Source_Id := Prj.Element (Source_Iterator);
         exit when Source_Id = Prj.No_Source;
         if Source_Id.all.Naming_Exception /= Prj.No then
            Process.all (Namet.Get_Name_String (Source_Id.all.Unit.all.Name),
                         Namet.Get_Name_String (Source_Id.all.File),
                         Source_Id.all.Kind /= Prj.Spec);
         end if;
         Prj.Next (Source_Iterator);
      end loop;
   end Iterate_On_Naming_Exceptions;

   procedure Iterate_On_Sources
     (Project : in Project_Record;
      Process : not null access procedure (Path : in String))
   is
      Source_Iterator : Prj.Source_Iterator;
      Source_Id       : Prj.Source_Id;
   begin
      Source_Iterator := Prj.For_Each_Source (Project.Project_Tree_Ref,
                                              Project.Project_Id);
      loop
         Source_Id := Prj.Element (Source_Iterator);
         exit when Source_Id = Prj.No_Source;
         pragma Assert (not Source_Id.all.Locally_Removed);
         pragma Assert (Source_Id.all.Replaced_By = Prj.No_Source);
         Process.all (Namet.Get_Name_String (Source_Id.all.Path.Name));
         Prj.Next (Source_Iterator);
      end loop;
   end Iterate_On_Sources;

   function Library_Dir
     (Project : in Project_Record)
     return String
   is
   begin
      return Namet.Get_Name_String (Project.Project_Id.all.Library_Dir.Name);
   end Library_Dir;

   function Library_Name
     (Project : in Project_Record)
     return String
   is
   begin
      return Namet.Get_Name_String (Project.Project_Id.all.Library_Name);
   end Library_Name;

   procedure Parse
     (Project     : in out Project_Record;
      Assignments : in     Assignment_Vectors.Vector;
      File_Name   : in     String)
   is
      Insignificant_String_Access     : GNAT.OS_Lib.String_Access;
      Unsavory_Project_Node_Id        : Prj.Tree.Project_Node_Id;
      Environment                     : Prj.Tree.Environment;
      Soporific_Project_Node_Tree     : Prj.Tree.Project_Node_Tree_Ref;
      Spiceless_Boolean               : Boolean;
      Processing_Flags : constant Prj.Processing_Flags := Prj.Create_Flags
        (Report_Error               => null,
         When_No_Sources            => Prj.Error,
         Require_Sources_Other_Lang => True, --  False for gnatmake
         Allow_Duplicate_Basenames  => False,
         Compiler_Driver_Mandatory  => False, --  True for gprbuild
         Error_On_Unknown_Language  => True); --  False for gnatmake
   begin
      --  This block really cleans the tree, see #736110.  Putting it
      --  later causes problems when parsing projects starting with
      --  "library project".
      if Project.Project_Tree_Ref /= Prj.No_Project_Tree then
         Prj.Free (Project.Project_Tree_Ref);
      end if;
      Project.Project_Tree_Ref := new Prj.Project_Tree_Data;
      Prj.Initialize (Project.Project_Tree_Ref);

      --  Dynamic allocation is unavoidable here, as the only way to
      --  deallocate substructures in Prj is Prj.Tree.Free. Affect
      --  inside the block so that the exception catcher may
      --  deallocate it before reraising.
      Soporific_Project_Node_Tree := new Prj.Tree.Project_Node_Tree_Data;
      Prj.Tree.Initialize (Soporific_Project_Node_Tree);
      Prj.Tree.Initialize (Environment, Processing_Flags);
      for Aff in 1 .. Natural (Assignment_Vectors.Length (Assignments)) loop
         Prj.Ext.Add (Environment.External,
                      Assignment_Vectors.Element (Assignments, Aff).Name,
                      Assignment_Vectors.Element (Assignments, Aff).Value);
      end loop;

      --  Prj.Pars would be convenient, but it ignores Default_Cgpr.

      --  Parse the main project file into a tree
      Sinput.P.Reset_First;
      Prj.Part.Parse (In_Tree           => Soporific_Project_Node_Tree,
                      Project           => Unsavory_Project_Node_Id,
                      Project_File_Name => File_Name,
                      Packages_To_Check => Prj.All_Packages,
                      Current_Directory => Ada.Directories.Current_Directory,
                      Is_Config_File    => False,
                      Env               => Environment);

      if Unsavory_Project_Node_Id /= Prj.Tree.Empty_Node then
         --  If there were no error, process the tree
         begin
            Prj.Conf.Process_Project_And_Apply_Config
              (Main_Project               => Project.Project_Id,
               User_Project_Node          => Unsavory_Project_Node_Id,
               Config_File_Name           => Default_Cgpr,
               Autoconf_Specified         => False,
               Project_Tree               => Project.Project_Tree_Ref,
               Project_Node_Tree          => Soporific_Project_Node_Tree,
               Env                        => Environment,
               Packages_To_Check          => null,
               Allow_Automatic_Generation => False,
               Automatically_Generated    => Spiceless_Boolean,
               Config_File_Path           => Insignificant_String_Access,
               Normalized_Hostname        => "");
            pragma Assert (Insignificant_String_Access.all = Default_Cgpr);
            GNAT.OS_Lib.Free (Insignificant_String_Access);
            pragma Assert (not Spiceless_Boolean);
         exception
            when Prj.Conf.Invalid_Config =>
               Project.Project_Id := Prj.No_Project;
         end;
         Prj.Err.Finalize;
      end if;
      if Project.Project_Id = Prj.No_Project then
         raise Parse_Error with '"' & File_Name & '"';
      end if;
      Prj.Tree.Free (Soporific_Project_Node_Tree);
      Prj.Tree.Free (Environment);
   exception
      when others =>
         Prj.Tree.Free (Soporific_Project_Node_Tree);
         Prj.Tree.Free (Environment);
         raise;
   end Parse;

begin
   --  Initialize Prj dependencies.
   --  Namet does not need initialization (anymore).
   Snames.Initialize;
   Csets.Initialize;
end Projects;
