------------------------------------------------------------------------------
--                                                                          --
--                          AUNITGLUE COMPONENTS                            --
--                                                                          --
--                A U N I T G L U E . E N V I R O N M E N T                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                     Copyright (C) 2008-2011, AdaCore                     --
--                                                                          --
-- AUNITGLUE 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.  AUNITGLUE  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.,                                      --
--                                                                          --
-- AUNITGLUE is maintained by AdaCore (http://www.adacore.com).             --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Text_IO;                use Ada.Text_IO;
with Ada.Strings;                use Ada.Strings;
with Ada.Strings.Fixed;          use Ada.Strings.Fixed;

with GNAT.Command_Line;          use GNAT.Command_Line;
with GNAT.Strings;

with Asis.Ada_Environments;      use Asis.Ada_Environments;

with GNAT.Directory_Operations;  use GNAT.Directory_Operations;

with ASIS_UL.Common;
with ASIS_UL.Compiler_Options;   use ASIS_UL.Compiler_Options;
with ASIS_UL.Debug;              use ASIS_UL.Debug;

with AUnitGlue.Options;          use AUnitGlue.Options;
with AUnitGlue.Common;           use AUnitGlue.Common;
with AUnitGlue.Source_Table;     use AUnitGlue.Source_Table;

with GNATCOLL.Projects;          use GNATCOLL.Projects;
with GNATCOLL.VFS;               use GNATCOLL.VFS;

package body AUnitGlue.Environment is

   Parameter_Error : exception;
   --  Is raised if the initialization is impossible or fails down because of
   --  any reason

   Config_Name : constant String := "gnat.adc";

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

   procedure Scan_Parameters;
   --  Scans the command-line parameters and sets the metrics to compute and
   --  sources to process.

   procedure Read_Args_From_File (Par_File_Name : String);
   --  Reads argument files from the file. Performs the same checks as when
   --  file names are read from the command line. This procedure assumes that
   --  the file named by Par_File_Name contains argument file names separated
   --  by one or more spaces.

   procedure Check_Parameters;
   --  Checks that parameter settings are compatible. Raises Parameter_Error
   --  and generates the diagnostic message if the check fails.

   function Detect_Predefined_Project_Path return File_Array_Access;
   --  Returns an array of default directories where compiler can search for
   --  included projects.

   procedure Create_Temp_Dir;
   --  Creates the temporary directory and stores its name in Temp_Dir.

   procedure Get_Naming_Info
     (Source_Project_Tree : GNATCOLL.Projects.Project_Tree);
   --  Gathers all naming info and creates a file with corresponding pragmas.

   procedure Brief_Help;
   --  Prints out the brief help.

   ------------------
   --  Brief_Help  --
   ------------------

   procedure Brief_Help is
   begin
      Put_Line ("usage: aunitglue [options] {filename} {-files filename} " &
                "[-cargs switches]");
      Put_Line (" options:");
      Put_Line
        ("  --test-as-parent - run overriden tests against tested package");
      Put_Line ("");
      Put_Line
        ("  --output=dirname - output directory location");
      Put_Line ("");
      Put_Line
        ("  -Pprjname        - name of project file to update " &
         "compilaton path;");
      Put_Line
        ("                     " &
         "if no sources are given in any other way,");
      Put_Line
        ("                     " &
         "sources from prjname are considered as arguments");
      Put_Line ("");
      Put_Line
        ("  -files filename  - name of the text file containing" &
         " a list of Ada");
      Put_Line
        ("                     source files for which harness should " &
         "be generated");
   end Brief_Help;

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

   procedure Check_Parameters is

      Tmp          : String_Access;
      No_More_Args : Boolean := True;

      --  Project support
      Source_Project_Tree : GNATCOLL.Projects.Project_Tree;
      --  Source project file name. Used for extraction of source files and
      --  paths for compiler.

      Project_Success : Boolean := False;

      Files :         File_Array_Access;
      Env   : Project_Environment_Access;

      procedure Update_Path_With_Project (Dirs : GNATCOLL.VFS.File_Array);
      --  Treats all the source dirs from project as -I option parameters.
      --  Also sets the value of Source_Dirs_Conflict flag.

      --------------------------------
      --  Update_Path_With_Project  --
      --------------------------------
      procedure Update_Path_With_Project (Dirs : GNATCOLL.VFS.File_Array) is
         Tmp : String_Access;
      begin
         for F in Dirs'Range loop
            Tmp := new String'
              (Normalize_Pathname (Name => Dirs (F).Display_Full_Name,
                                   Case_Sensitive => False));

            if Tmp.all & Directory_Separator = Output_Dir.all then
               Report_Err ("aunitglue: invalid output directory, cannot mix " &
                           "up tests and infrastructure");
               Free (Tmp);
               raise Parameter_Error;
            end if;

            Store_I_Option (Tmp.all);
            Free (Tmp);
         end loop;
      end Update_Path_With_Project;

   begin
      Initialize (Env);

      if Output_Dir.all /= "." then

         if Is_Regular_File (Output_Dir.all) then
            Report_Err ("aunitglue: cannot create the output directory");
            raise Parameter_Error;
         elsif not Is_Directory (Output_Dir.all) then

            begin
               Make_Dir (Output_Dir.all);
            exception
               when Directory_Error =>
                  Report_Err ("aunitglue: cannot create the output directory");
                  raise Parameter_Error;
            end;

         end if;

      end if;

      Tmp := new String'(Normalize_Pathname
        (Name           => Output_Dir.all,
         Case_Sensitive => False));
      Free (Output_Dir);
      Output_Dir := new String'(Tmp.all & Directory_Separator);
      Free (Tmp);

      if Source_Prj.all /= "" then
         if not Is_Regular_File (Source_Prj.all) then
            Report_Err ("aunitglue: project file " &
                        Source_Prj.all & " does not exist");
            raise Parameter_Error;
         end if;

         Tmp := new String'(Normalize_Pathname
           (Name => Source_Prj.all,
            Case_Sensitive => False));
         Free (Source_Prj);
         Source_Prj := new String'(Tmp.all);
         Free (Tmp);

         Env.Set_Predefined_Project_Path (Detect_Predefined_Project_Path.all);

         Source_Project_Tree.Load (GNATCOLL.VFS.Create (+Source_Prj.all), Env);

         Update_Path_With_Project
           (Source_Project_Tree.Root_Project.Source_Dirs (Recursive => True));

         Project_Success := True;

      end if;

      Create_Temp_Dir;
      Change_Dir (Temp_Dir.all);

      if Project_Success then
         Get_Naming_Info (Source_Project_Tree);
      end if;

      if SF_Table_Empty then

         if Source_Prj.all = "" then

            Report_Err ("No input source file set");
            Brief_Help;
            raise Parameter_Error;

         else

            Files :=
              Source_Project_Tree.Root_Project.Source_Files
                (Recursive => False);

            for F in Files'Range loop
               Add_Source_To_Process (Files (F).Display_Full_Name,
                                      No_More_Args);
               exit when No_More_Args;
            end loop;

            --  If SF_Table is still empty, that means that the given project
            --  does not have any source files.
            if SF_Table_Empty then
               Report_Err (Source_Prj.all & " doesn't contain source files");
               Brief_Help;
               raise Parameter_Error;
            end if;

         end if;

      end if;

      Reset_Location_Iterator;
      loop

         Tmp := new String'(Normalize_Pathname
           (Name => Next_Source_Location,
            Case_Sensitive => False));
         exit when Tmp.all = "";

         if Tmp.all & Directory_Separator = Output_Dir.all then
            Report_Err ("aunitglue: invalid output directory, cannot mix " &
                         "up tests and infrastructure");
            raise Parameter_Error;
         end if;

      end loop;

      Process_ADA_PRJ_INCLUDE_FILE;
      Store_I_Options;
      Set_Arg_List;
      Free (Env);
   end Check_Parameters;

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

   procedure Clean_Up is
   begin

      Context_Clean_Up;

      --  Cleaning up temporary dir

      if Temp_Dir /= null then

         if not Is_Directory (Temp_Dir.all) then
            --  We may be inside this temporary directory
            Change_Dir ("..");
         end if;

         begin
            Remove_Dir (Temp_Dir.all, Recursive => True);
         exception
            when Directory_Error =>
               Free (Temp_Dir);  -- to avoid cycling
               Report_Err ("aunitglue: cannot remove temporary directory");
               raise Fatal_Error;
         end;

         Free (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;

   ---------------------
   -- Create_Temp_Dir --
   ---------------------

   procedure Create_Temp_Dir is
      FD        : File_Descriptor;
      Temp_Name : Temp_File_Name;
      Success   : Boolean;
   begin
      --  Here we use exactly the same approach as in gnatelim

      --  ??? 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
         Report_Err ("aunitglue: cannot delete the temporary file that was "
                     & "just created");

         raise Fatal_Error;
      end if;

      Make_Dir (Temp_Name);

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

   exception
      when Directory_Error =>
         Report_Err ("aunitglue: cannot create the temporary directory");
         raise Fatal_Error;
   end Create_Temp_Dir;

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

   procedure Initialize is
   begin
      Scan_Parameters;
      Check_Parameters;

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

   --------------------------------------
   --  Detect_Predefined_Project_Path  --
   --------------------------------------
   function Detect_Predefined_Project_Path return File_Array_Access
   is

      FD        : File_Descriptor;
      Temp_Name : String_Access;

      Tmp_File : File_Type;
      Tmp_Str  : String_Access;

      Exit_Code  : Integer;
      Suffix_Pos : Integer;
      First_Idx  : Integer;
      Prefix     : String_Access;

      Project_Path_Heading : constant String := "Project Search Path:";

      Collect_Dirs   : Boolean := False;
      Spawns_Success : Boolean;

      Project_Dirs : File_Array_Access := new File_Array'(Empty_File_Array);

      Gnatls    : constant String               := "gnatls";
      Arg_List  : constant Argument_List_Access :=
        Argument_String_To_List ("-v");
   begin

      if ASIS_UL.Common.Gcc_To_Call = null then
         Prefix := new String'("");
      else
         Suffix_Pos := ASIS_UL.Common.Gcc_To_Call.all'Last;
         First_Idx  := ASIS_UL.Common.Gcc_To_Call.all'First;
         loop

            if ASIS_UL.Common.Gcc_To_Call.all
              (Suffix_Pos - 2 .. Suffix_Pos) = "gcc"
            then
               Prefix := new String'(ASIS_UL.Common.Gcc_To_Call.all
                                       (First_Idx .. Suffix_Pos - 3));
               exit;
            end if;

            Suffix_Pos := Suffix_Pos - 1;

         end loop;
      end if;

      Create_Temp_Output_File (FD, Temp_Name);

      Spawn
        (Program_Name => Prefix.all & Gnatls,
         Args         => Arg_List.all,
         Output_File  => Temp_Name.all,
         Success      => Spawns_Success,
         Return_Code  => Exit_Code,
         Err_To_Out   => False);

      Close (FD);

      if not Spawns_Success then
         return Project_Dirs;
      end if;

      Open (Tmp_File, In_File, Temp_Name.all);

      while not End_Of_File (Tmp_File) loop

         Tmp_Str := new String'(Trim (Get_Line (Tmp_File), Both));

         if Collect_Dirs then
            Append (Project_Dirs, GNATCOLL.VFS.Create (+Tmp_Str.all));
         end if;

         if Tmp_Str.all = Project_Path_Heading then

            Free (Tmp_Str);
            Tmp_Str := new String'(Get_Line (Tmp_File));
            --  Getting rid of "<Current_Directory>"

            Collect_Dirs := True;
         end if;

         Free (Tmp_Str);

      end loop;

      Delete (Tmp_File);

      return Project_Dirs;

   exception
         when others =>
         Report_Err ("aunitglue: cannot detect predefined project path");
         --  Exception info will be generated in main driver
         raise;
   end Detect_Predefined_Project_Path;

   ---------------------
   -- Get_Naming_Info --
   ---------------------

   procedure Get_Naming_Info
     (Source_Project_Tree : GNATCOLL.Projects.Project_Tree)
   is
      Project : Project_Type;
      Iterator        : Project_Iterator :=
        Start (Source_Project_Tree.Root_Project);

      Output_File : File_Type;

   begin

      Create (Output_File, Out_File, Config_Name);

      loop
         Project := Current (Iterator);
         exit when Project = No_Project;

         if Has_Attribute (Project, Spec_Attribute) then
            declare
               Atr_Indexes : constant GNAT.Strings.String_List :=
                 Attribute_Indexes (Project, Spec_Attribute);
            begin
               for I in Atr_Indexes'Range loop
                  Put_Line
                    (Output_File,
                     "pragma Source_File_Name (" &
                     Atr_Indexes (I).all         &
                     ",");
                  Put_Line
                    (Output_File,
                     "Spec_File_Name => """  &
                     Attribute_Value
                       (Project,
                        Spec_Attribute,
                        Atr_Indexes (I).all) &
                     """);");
               end loop;
            end;
         end if;

         if Has_Attribute (Project, Body_Attribute) then
            declare
               Atr_Indexes : constant GNAT.Strings.String_List :=
                 Attribute_Indexes (Project, Body_Attribute);
            begin
               for I in Atr_Indexes'Range loop
                  Put_Line
                    (Output_File,
                     "pragma Source_File_Name (" &
                     Atr_Indexes (I).all         &
                     ",");
                  Put_Line
                    (Output_File,
                     "Body_File_Name => """  &
                     Attribute_Value
                       (Project,
                        Body_Attribute,
                        Atr_Indexes (I).all) &
                     """);");
               end loop;
            end;
         end if;

         Next (Iterator);
      end loop;

      Close (Output_File);

   end Get_Naming_Info;

   -------------------------
   -- Read_Args_From_File --
   -------------------------

   procedure Read_Args_From_File (Par_File_Name : String) is
      No_More_Args : Boolean := False;

      Arg_File         : File_Type;
      File_Name_Buffer : String (1 .. 16 * 1024);
      File_Name_Len    : Natural := 0;
      Next_Ch          : Character;
      End_Of_Line      : Boolean;

      function Get_File_Name return String;
      --  Reads from Par_File_Name the name of the next file (the file to read
      --  from should exist and be opened). Returns an empty string if there is
      --  no file names in Par_File_Name any more

      function Get_File_Name return String is
      begin
         File_Name_Len := 0;

         if not End_Of_File (Arg_File) then
            Get (Arg_File, Next_Ch);

            while Next_Ch = ' ' loop
               exit when End_Of_File (Arg_File);
               Get (Arg_File, Next_Ch);
            end loop;

            while Next_Ch /= ' ' loop
               File_Name_Len := File_Name_Len + 1;
               File_Name_Buffer (File_Name_Len) := Next_Ch;

               Look_Ahead (Arg_File, Next_Ch, End_Of_Line);

               exit when End_Of_Line or else End_Of_File (Arg_File);

               Get (Arg_File, Next_Ch);
            end loop;

         end if;

         return File_Name_Buffer (1 .. File_Name_Len);
      end Get_File_Name;

   begin

      if not Is_Regular_File (Par_File_Name) then
         Report_Err ("aunitglue: " & Par_File_Name & " does not exist");
         Brief_Help;
         raise Parameter_Error;
      end if;

      Open (Arg_File, In_File, Par_File_Name);

      loop
         Add_Source_To_Process (Get_File_Name, No_More_Args);
         exit when No_More_Args;
      end loop;

      Close (Arg_File);
   exception
      when others =>
         Report_Err ("aunitglue: cannot read arguments from " & Par_File_Name);
         --  Exception info will be generated in main driver
         raise;
   end Read_Args_From_File;

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

   procedure Scan_Parameters is
      No_More_Args : Boolean;
   begin
      Initialize_Option_Scan
        (Stop_At_First_Non_Switch => True,
         Section_Delimiters       => "cargs");

      loop
         case GNAT.Command_Line.Getopt ("files= h d? P? q "    &
                                        "-test-as-parent "     &
                                        "-output= "            &
                                        "-suppress-contracts " &
                                        "-glue-all")
         is
            when ASCII.NUL =>
               exit;

            when 'f' =>

               if Full_Switch = "files" then
                  Read_Args_From_File (Parameter);
               end if;

            when '-' =>

               if Full_Switch = "-test-as-parent" then
                  Liskov_Suite := True;
               end if;

               if Full_Switch = "-output" then
                  Output_Dir := new String'(Parameter);
               end if;

               if Full_Switch = "-suppress-contracts" then
                  Suppress_Contacts := True;
               end if;

               if Full_Switch = "-glue-all" then
                  Glue_Unimplemented := True;
               end if;

            when 'd' =>

               if Full_Switch = "d" then
                  Set_Debug_Options (Parameter);
               end if;

            when 'P' =>
               Source_Prj := new String'(Parameter);

            when 'q' =>
               Quiet := True;

            when others =>
               Brief_Help;
               raise Parameter_Error;
         end case;
      end loop;

      loop
         Add_Source_To_Process (Get_Argument, No_More_Args);
         exit when No_More_Args;
      end loop;

      Process_cargs_Section;

   exception
      when GNAT.Command_Line.Invalid_Switch =>
         Report_Err ("aunitglue: invalid switch : " & Full_Switch);
         Brief_Help;

         raise Parameter_Error;

      when GNAT.Command_Line.Invalid_Parameter =>
         Report_Err ("aunitglue: missing parameter for: -" & Full_Switch);
         Brief_Help;

         raise Parameter_Error;

   end Scan_Parameters;

end AUnitGlue.Environment;
