------------------------------------------------------------------------------
--                                                                          --
--                     ASIS UTILITY LIBRARY COMPONENTS                      --
--                                                                          --
--                  A S I S _ U L . E N V I R O N M E N T                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                    Copyright (C) 2004-2011, AdaCore                      --
--                                                                          --
-- Asis Utility Library (ASIS UL) 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 2, or (at your --
-- option)  any later version.  ASIS UL  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  distributed with GNAT; see file --
-- COPYING. If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, USA.                         --
--                                                                          --
-- ASIS UL is maintained by AdaCore (http://www.adacore.com).               --
--                                                                          --
------------------------------------------------------------------------------

pragma Ada_2005;

with Ada.Characters.Conversions;  use Ada.Characters.Conversions;
with Ada.Text_IO;                 use Ada.Text_IO;

with GNAT.Command_Line;           use GNAT.Command_Line;

with Hostparm;

with Asis.Ada_Environments;       use Asis.Ada_Environments;
with Asis.Extensions;             use Asis.Extensions;
with Asis.Implementation;         use Asis.Implementation;

with A4G.A_Types;                 use A4G.A_Types;

with ASIS_UL.Common;              use ASIS_UL.Common;
with ASIS_UL.Compiler_Options;    use ASIS_UL.Compiler_Options;
with ASIS_UL.Debug;               use ASIS_UL.Debug;
with ASIS_UL.Options;
with ASIS_UL.Output;              use ASIS_UL.Output;
with ASIS_UL.Source_Table;        use ASIS_UL.Source_Table;
with ASIS_UL.Utilities;           use ASIS_UL.Utilities;

package body ASIS_UL.Environment is

   Tmpdir_Needs_To_Be_Displayed : Boolean := True;

   Tmpdir    : constant String := "TMPDIR";
   Gnutmpdir : constant String := "GNUTMPDIR";
   No_Dir    : aliased String  := "";
   Temp_Dir  : String_Access   := No_Dir'Access;
   --  If non-empty, points to the name of the directory to create the tool's
   --  temporary directory into. If empty, the temporary directory is created
   --  in the current directory.

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Scan_Parameters;
   --  Scans the tool parameters and initializes the corresponding data
   --  structures.
   --
   --  Because the parameters are tool-specific, the corresponding subunit
   --  should be provided for each tool

   function More_Arguments return Boolean;
   --  Is supposed to be used as a common part of Scan_Parameters in the
   --  loop that iterates through the command line. Is supposed to be called
   --  when Getop returns ASCII.NUL. Tries to read arguments and store them (if
   --  any). returns True if at least one argument is found and False
   --  otherwise.
   pragma Warnings (Off, More_Arguments);
   --  At least gnatstub does not use this procedure, so we have to avoid
   --  warnings about unreferenced procedure

   procedure Check_Parameters;
   --  Checks that the tool settings are compatible with each other. All
   --  possible check are tool-specific, the corresponding subunit
   --  should be provided for each tool

   --  These two procedures Scan_Parameters and Check_Parameters - are a part
   --  of the Initialize procedure.  The important thing is that after
   --  finishing Initialize either the source table should contain at least one
   --  name of an existing file (in case if the tool is based on ??? driver),
   --  or ASIS_UL.Common.Arg_File should point to an existing file (in case if
   --  the tool is based on ASIS_UL.One_Arg_Driver driver procedure). File
   --  names in both cases should be full normalized names.
   --
   --  ASIS_UL.Common.Arg_List should collect all the needed options to call
   --  gcc for tree creation

   procedure Tool_Specific_Initialization_1;
   procedure Tool_Specific_Initialization_2;
   --  Do the initialization actions that are specific for a tool. The first
   --  subprogram is called before reading the tool command-line parameters,
   --  the second - when the command-line paramenets have just been read in and
   --  analyzed. If the tool needs any specific initialization actions, the
   --  corresponding subunits should be provided for these subprograms.

   procedure Set_Tree_Name;
   --  This procedure is supposed to be called when a tree file has just been
   --  created for the Ada source which (full normalized) name is contained
   --  in ASIS_UL.Common.Arg_File. It sets into ASIS_UL.Common.Tree_File the
   --  (short) name of the corresponding tree file.

   ----------------------
   -- Check_Parameters --
   ----------------------

   procedure Check_Parameters is separate;

   --------------
   -- Clean_Up --
   --------------

   procedure Clean_Up is
      Success : Boolean := False;
   begin
      Source_Table_Debug_Image;

      Context_Clean_Up;

      --  Cleaning up temporary dir

      if not Debug_Flag_N and then Tool_Temp_Dir /= null then

         Change_Dir (Tool_Current_Dir);

         for J in 1 .. 10 loop
            --  On windows, there might be a slight delay between the return of
            --  the close function on a file descriptor and the actual closing
            --  done by the system. Since it's not possible to remove a
            --  directory as long as there are handles on it, this Remove_Dir
            --  may fail. So, if a call to Remove_Dir raises Directory_Error,
            --  we try several times after some delay, and only if all the
            --  attempts fail, we generate an error message and raise an
            --  exception
            --  be performed.

            begin
               Remove_Dir (Tool_Temp_Dir.all, Recursive => True);
               Success := True;
               exit;
            exception
               when Directory_Error =>
                  delay 0.05;
            end;

         end loop;

         if not Success then
            --  Because of some unknown reason the temporary directory cannot
            --  be removed:
            Free (Tool_Temp_Dir);  -- to avoid cycling
            Error ("cannot remove temporary directory");
            raise Fatal_Error;
         end if;

         Free (Tool_Temp_Dir);

      end if;

   end Clean_Up;

   ----------------------
   -- Context_Clean_Up --
   ----------------------

   procedure Context_Clean_Up is
   begin

      if Is_Open (The_Context) then
         Close (The_Context);
      end if;

      if Has_Associations (The_Context) then
         Dissociate (The_Context);
      end if;

   end Context_Clean_Up;

   --------------------
   -- Go_To_Temp_Dir --
   --------------------

   procedure Go_To_Temp_Dir (With_Dir_For_Comp_Output : Boolean := False) is
      FD        : File_Descriptor;
      Temp_Name : Temp_File_Name;
      Success   : Boolean;
   begin
      if Temp_Dir'Length /= 0 then

         --  In verbose mode, display once the value of TMPDIR, so that
         --  if temp files cannot be created, it is easier to understand
         --  where temp files are supposed to be created.

         if ASIS_UL.Options.Verbose_Mode and then
           Tmpdir_Needs_To_Be_Displayed
         then
            Info_No_EOL ("TMPDIR = """);
            Info_No_EOL (Temp_Dir.all);
            Info        ("""");
            Tmpdir_Needs_To_Be_Displayed := False;
         end if;

         Change_Dir (Temp_Dir.all);
      end if;

      --  ??? We create the temp dir by first creating the temp file, then
      --  closing and deleting it, then creating a dir with the same name.
      --  This is not atomary as another program can sneak in between file
      --  deletion and dir creation and snatch this name for itself. This is
      --  quite unlikely and anyway we don't have any other system-independent
      --  way at the moment
      Create_Temp_File (FD, Temp_Name);
      Close (FD);
      Delete_File (Temp_Name, Success);

      if not Success then
         Error ("can not delete the temporary file that was "
              & "just created");

         raise Fatal_Error;
      end if;

      Make_Dir (Temp_Name);

      Tool_Temp_Dir := new String'
        (Normalize_Pathname
           (Temp_Name (Temp_Name'First .. Temp_Name'Last - 1)));

      Change_Dir (Tool_Current_Dir);

      if Is_Regular_File ("gnat.adc") then

         if Hostparm.OpenVMS then
            Copy_File
              (Name     => "gnat.adc",
               Pathname => Tool_Temp_Dir.all & Directory_Separator &
                           "gnat.adc",
               Success  => Success,
               Mode     => Copy,
               Preserve => None);

         else
            Copy_File
              (Name     => "gnat.adc",
               Pathname => Tool_Temp_Dir.all & Directory_Separator &
                           "gnat.adc",
               Success  => Success,
               Mode     => Copy);
         end if;

      end if;

      Change_Dir (Tool_Temp_Dir.all);

      if Project_File /= null
        and then
         Project_Support_Type = Use_Tmp_Project_File
      then

         declare
            Temp_Project_File : File_Type;
         begin
            --  Creating the temporary project file
            Create (Temp_Project_File, Out_File, "tmp.gpr");

            Put (Temp_Project_File, "project Tmp extends """);
            Put (Temp_Project_File, Project_File.all);
            Put (Temp_Project_File, """ is");
            New_Line (Temp_Project_File);

            Put (Temp_Project_File, "   for Object_Dir use """ &
                 ASIS_Current_Directory.all & """;");
            New_Line (Temp_Project_File);

            Put (Temp_Project_File, "end Tmp;");
            New_Line (Temp_Project_File);

            Close (Temp_Project_File);

            --  Storing the temporary project file as an option:

            Store_Option ("-Ptmp.gpr");
            Set_Arg_List;

         exception
            when others =>
               Error ("can not create the temporary project file");
               raise Fatal_Error;
         end;

      end if;

      if With_Dir_For_Comp_Output then
         Create_Temp_File (FD, Temp_Name);
         Close (FD);
         Delete_File (Temp_Name, Success);

         if not Success then
            Error ("can not delete the temporary file that was "
                 & "just created");

            raise Fatal_Error;
         end if;

         Make_Dir (Temp_Name);

         Compiler_Output_File_Name := new String'
           (Temp_Name (Temp_Name'First .. Temp_Name'Last - 1) &
            Directory_Separator & "compiler_diag.txt");
      end if;

   exception
      when Directory_Error =>
         Error ("can not create the temporary directory");
         raise Fatal_Error;
   end Go_To_Temp_Dir;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      Tool_Specific_Initialization_1;
      --  A tool-specific version should be provided!

      Scan_Parameters;  --  A tool-specific version should be provided!
      Check_Parameters; --  A tool-specific version should be provided!

      Tool_Specific_Initialization_2;
      --  A tool-specific version should be provided!

      if not ASIS_UL.Options.Nothing_To_Do then
         Go_To_Temp_Dir;
         Store_I_Options;
      end if;

   exception
      when Parameter_Error | Fatal_Error =>
         --  The diagnosis is already generated
         raise Fatal_Error;
      when others =>
         Error ("initialization failed");
         --  Exception info will be generated in main driver
         raise;
   end Initialize;

   --------------------
   -- More_Arguments --
   --------------------

   function More_Arguments return Boolean is
      No_More_Args    : Boolean;
      First_Iteration : Boolean := True;
      Result          : Boolean;
   begin
      loop
         Store_Sources_To_Process
           (Get_Argument (Do_Expansion => True), No_More_Args);

         if First_Iteration then
            Result          := not No_More_Args;
            First_Iteration := False;
         end if;

         exit when No_More_Args;
      end loop;

      return Result;
   end More_Arguments;

   ---------------------
   -- Prepare_Context --
   ---------------------

   procedure Prepare_Context (Success : out Boolean) is
   begin
      Compile
        (Source_File  => ASIS_UL.Common.Arg_File,
         Args         => ASIS_UL.Compiler_Options.Arg_List.all,
         Success      => Success,
         GCC          => Gcc_To_Call,
         Use_GNATMAKE => Use_Gnatmake_To_Compile,
         Use_Temp_Prj => Project_Support_Type = Use_Tmp_Project_File,
         Display_Call => Debug_Flag_D);

      if not Success then
         Error ("the argument source is illegal");
      else
         Set_Tree_Name;

         Asis.Implementation.Initialize ("-ws");

         Asis.Ada_Environments.Associate
           (The_Context => The_Context,
            Name        => "",
            Parameters  => "-C1 " & To_Wide_String (Tree_File.all));

         Open (The_Context);

         if Debug_Flag_T then
            Print_Tree_Sources;
         end if;

         The_CU := Asis.Extensions.Main_Unit_In_Current_Tree (The_Context);
      end if;

   end Prepare_Context;

   ---------------------
   -- Scan_Parameters --
   ---------------------

   procedure Scan_Parameters is separate;

   -------------------
   -- Set_Tree_Name --
   -------------------

   procedure Set_Tree_Name is
      Dot_Idx : Natural := 0;
      DS_Idx  : Natural;
   begin

      Free (Tree_File);

      if Arg_File = null then
         Tree_File := new String'("");
      else
         for J in reverse Arg_File'Range loop
            if Arg_File (J) = '.' then
               Dot_Idx := J - 1;
               exit;
            end if;
         end loop;

         DS_Idx := Arg_File'First;

         for J in reverse Arg_File'Range loop
            if Arg_File (J) = Directory_Separator then
               DS_Idx := J + 1;
               exit;
            end if;
         end loop;

         Tree_File := new String'(Arg_File (DS_Idx .. Dot_Idx) & ".adt");

      end if;

   end Set_Tree_Name;

   ----------------------------------
   -- Tool_Specific_Initialization --
   ----------------------------------

   procedure Tool_Specific_Initialization_1 is separate;
   procedure Tool_Specific_Initialization_2 is separate;

begin
   --  Check if we have the rirectory for temporary stuff specified
   declare
      Dir : String_Access;

   begin
      --  On VMS, if GNUTMPDIR is defined, use it

      if Hostparm.OpenVMS then
         Dir := Getenv (Gnutmpdir);

         --  Otherwise, if GNUTMPDIR is not defined, try TMPDIR

         if Dir'Length = 0 then
            Dir := Getenv (Tmpdir);
         end if;

      else
         Dir := Getenv (Tmpdir);
      end if;

      if Dir'Length > 0 and then
        Is_Absolute_Path (Dir.all) and then
        Is_Directory (Dir.all)
      then
         Temp_Dir := new String'(Normalize_Pathname (Dir.all));
      end if;

      Free (Dir);
   end;
end ASIS_UL.Environment;
