-------------------------------------------------------------------------------
-- (C) Altran Praxis Limited
-------------------------------------------------------------------------------
--
-- The SPARK toolset is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 3, or (at your option) any later
-- version. The SPARK toolset 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 the SPARK toolset; see file
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
-- the license.
--
--=============================================================================

---------------------------------------------------------------------------------
-- This package body provides the filesystem interface which allows the
-- Examiner to determine the current drive, the full pathname of a given file,
-- and various properties of files. It also reads the command line and
-- provides the facility to create a directory.
---------------------------------------------------------------------------------

with Ada.Characters.Latin_1;
with Ada.Command_Line;
with SPARK.Ada.Strings.Unbounded.Not_SPARK;
with E_Strings.Not_SPARK;
with GNAT.Directory_Operations;
with GNAT.IO_Aux;
with GNAT.OS_Lib;

#if Target = "Intel_WinNT" then
with Ada.Characters.Handling;
with Interfaces.C_Streams;
#end if;

use type GNAT.OS_Lib.String_Access;

package body FileSystem
is
   -- NOTE - this package body is Ada95, not SPARK

   --=========================================================================
   -- Filesystem package body
   --
   -- This body is split into section according to the various combinations
   -- of Host Compiler and Target Platform.  Effort is made to make as much
   -- code common to as many platforms as possible.  For example, many
   -- procedures are common to all platforms where the host compiler is
   -- GNAT, regardless of whether the target is Windows, Solaris, Linux,
   -- OS X or whatever.
   --
   -- Contents
   --   1  Linker Options (GNAT/Intel Windows only)
   --   2  Command-Line Arguments and Identification (All platforms/hosts)
   --   3  Casing of filenames (All platforms/hosts)
   --   4  Exported Operations - All hosts and targets
   --   5  Exported Operations - All GNAT hosts
   --=========================================================================

   --------------------------------------------------------------
   -- Section 1
   --
   -- Linker Options (CFR 786)
   --   On NT we currently require the system stack reserve and
   -- commit setting to be increased.
   --------------------------------------------------------------

   -- This section is no longer needed.  Stack size setting in the linker
   -- is still required on Windows, but this is done in the project file and/or
   -- makefile

   -----------------------------------------------------------------
   -- Section 2
   --
   -- Functions relating to reading command-line arguments
   -----------------------------------------------------------------

   function Argument_Separator return Character
   is
   begin
#if Target = "Intel_WinNT" then
      -- We use Nul to separate arguments on NT, since we want spaces to
      -- be allowed in filenames (CFR 783)
      return Ada.Characters.Latin_1.NUL;
#else -- Solaris, Linux, Mac OS X
      return ' ';
#end if;
   end Argument_Separator;

   function Is_An_Argument_Terminator (Ch : Character) return Boolean
   is
   begin
#if Target = "Intel_WinNT" then
      return Ch = Ada.Characters.Latin_1.NUL or Ch = ',' or Ch = '=';
#else -- Solaris, Linux, OS X
      return Ch = ' ' or Ch = '=';
#end if;
   end Is_An_Argument_Terminator;

   function Use_Windows_Command_Line return Boolean
   is
   begin
#if Target = "Intel_WinNT" then
      return True;
#else -- Solaris, Linux, Mac OS X
      return False;
#end if;
   end Use_Windows_Command_Line;

   function Use_Unix_Command_Line return Boolean
   is
   begin
#if Target = "SPARC_Solaris" or Target = "Intel_Linux" or Target = "Darwin" then
      return True;
#else -- Solaris, Linux, Mac OS X
      return False;
#end if;
   end Use_Unix_Command_Line;

   -----------------------------------------------------------------
   -- Section 3
   --
   -- Functions relating to the casing of filenames
   -----------------------------------------------------------------

   function Case_Of_Files_For_Open (E_Str : E_Strings.T)
                                   return E_Strings.T
   is
   begin
      return E_Str; -- unchanged
   end Case_Of_Files_For_Open;

   function Case_Of_Files_For_Create (E_Str : E_Strings.T)
                                     return E_Strings.T
   is
   begin
      return E_Str; -- unchanged
   end Case_Of_Files_For_Create;

   -----------------------------------------------------------------
   -- Section 4
   --
   -- Exported operations - All hosts and targets
   -----------------------------------------------------------------

   procedure Check_Listing_Extension
     (Source_Name : in     E_Strings.T;
      Fn          : in out E_Strings.T;
      Ext         : in     E_Strings.T)
   is
      Source_Extension : E_Strings.T;

      function Get_File_Ext (File_Name : E_Strings.T)
                            return E_Strings.T
      is
         File_Ext : E_Strings.T;
         First    : E_Strings.Lengths;
      begin --Get_File_Ext
         File_Ext := E_Strings.Empty_String;

         if E_Strings.Get_Length (E_Str => File_Name) > 0 then
            First := 0;
            for I in reverse E_Strings.Positions range 1 .. E_Strings.Get_Length (E_Str => File_Name) loop
               if E_Strings.Get_Element (E_Str => File_Name,
                                         Pos   => I) = '.' then
                  -- Start of extension found
                  First := I + 1;
                  exit;
               end if;
            end loop;
            -- first now point to the first character after the '.' or it's 0 because
            -- no extension (i.e. no ',') was found
            if First > 0 then
               for I in E_Strings.Positions range First .. E_Strings.Get_Length (E_Str => File_Name) loop
                  exit when E_Strings.Get_Element (E_Str => File_Name,
                                                   Pos   => I) = ' '; --fallen of the end of the extension

                  -- If we are here we have a valid character to insert
                  E_Strings.Append_Char (E_Str => File_Ext,
                                         Ch    => E_Strings.Get_Element (E_Str => File_Name,
                                                                         Pos   => I));
               end loop;
            end if;
         end if;
         return File_Ext;
      end Get_File_Ext;

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

      function Create_New_Extension (Source_Ext,
                                       Ext      : E_Strings.T)
                                    return E_Strings.T
      is

         Result  : E_Strings.T;

         function Substitute_Character (Source_Char,
                                          Ext_Char,
                                          Default_Char : Character) return Character
         is
            Wild_Card : constant Character := '_';
            Result    : Character;
         begin --Substitute_Character
            if Ext_Char = Wild_Card then
               -- We need to look at source and possible default extensions
               if Source_Char = ' ' then
                  -- no matching character from source so return default
                  Result := Default_Char;
               else
                  Result := Source_Char;
               end if;
            else
               -- non wild-card so just return it
               Result := Ext_Char;
            end if;
            return Result;
         end Substitute_Character;

      begin -- Create_New_Extension;
         Result := E_Strings.Empty_String;
         E_Strings.Append_Char
           (E_Str => Result,
            Ch    => Substitute_Character (Source_Char  => E_Strings.Get_Element (E_Str => Source_Ext,
                                                                                  Pos   => 1),
                                           Ext_Char     => E_Strings.Get_Element (E_Str => Ext,
                                                                                  Pos   => 1),
                                           Default_Char => 'l'));
         E_Strings.Append_Char
           (E_Str => Result,
            Ch    => Substitute_Character (Source_Char  => E_Strings.Get_Element (E_Str => Source_Ext,
                                                                                  Pos   => 2),
                                           Ext_Char     => E_Strings.Get_Element (E_Str => Ext,
                                                                                  Pos   => 2),
                                           Default_Char => 's'));
         E_Strings.Append_Char
           (E_Str => Result,
            Ch    => Substitute_Character (Source_Char  => E_Strings.Get_Element (E_Str => Source_Ext,
                                                                                  Pos   => 3),
                                           Ext_Char     => E_Strings.Get_Element (E_Str => Ext,
                                                                                  Pos   => 3),
                                           Default_Char => 't'));

         --safety check: if Result = Source_Ext then force to default .lst
         if E_Strings.Eq_String (E_Str1 => Result,
                                 E_Str2 => Source_Ext) then
            Result := E_Strings.Copy_String ("lst");
         end if;
         return Result;
      end Create_New_Extension;

   begin -- Check_Listing_Extension
      if E_Strings.Get_Length (E_Str => Get_File_Ext (File_Name => Fn)) = 0 then --no existing extension
         if E_Strings.Get_Length (E_Str => Fn) /= 0 and then -- and then required here.
           E_Strings.Get_Element (E_Str => Fn,
                                  Pos   => E_Strings.Get_Length (E_Str => Fn)) /= '.' then -- prevent double dot
            E_Strings.Append_Char (E_Str => Fn,
                                   Ch    => '.');
         end if;
         Source_Extension := Get_File_Ext (File_Name => Source_Name);
         --The source extension may be less than 3 characters long.  We force
         --it to 3 characters here (it is padded with spaces anyway) for use
         --by Create_New_Extension
         E_Strings.Append_Examiner_String (E_Str1 => Fn,
                                           E_Str2 => Create_New_Extension (Source_Ext => Source_Extension,
                                                                           Ext        => Ext));
      end if;
   end Check_Listing_Extension;

   -----------------------------------------------------------------
   -- Section 5
   --
   -- Exported operations - All GNAT hosted platforms
   -----------------------------------------------------------------

   function Get_Environment_Variable (Env_Var_Name : String)
                                   return E_Strings.T
   is
   begin
      return E_Strings.Copy_String (Str => GNAT.OS_Lib.Getenv (Env_Var_Name).all);
   end Get_Environment_Variable;

   procedure Open_Source_File
      (File   : in out SPARK_IO.File_Type;
       Name   : in     E_Strings.T;
       Status :    out SPARK_IO.File_Status)
   is
   begin
      E_Strings.Open (File         => File,
                     Mode_Of_File => SPARK_IO.In_File,
                     Name_Of_File => Name,
                     Form_Of_File => "shared=no",
                     Status       => Status);
   end Open_Source_File;

   procedure Read_Cmd_Line (Cmd_Line_Found : out Boolean;
                            Cmd_Line       : out E_Strings.T)
   is
      Loc_Ptr   : E_Strings.Lengths := 0;
      Loc_Line  : E_Strings.T := E_Strings.Empty_String;
      Arg_Count : constant Natural := Ada.Command_Line.Argument_Count;
   begin

      for I in Positive range 1 .. Arg_Count loop
         declare
            Arg : constant E_Strings.T := E_Strings.Copy_String (Ada.Command_Line.Argument (I));
         begin
            Loc_Ptr := Loc_Ptr + E_Strings.Get_Length (Arg);
            E_Strings.Append_Examiner_String (Loc_Line, Arg);
         end;
         Loc_Ptr := Loc_Ptr + 1;
         E_Strings.Append_Char (Loc_Line, Argument_Separator);
      end loop;

      Cmd_Line_Found := (Loc_Ptr /= 0);
      Cmd_Line       := Loc_Line;

   end Read_Cmd_Line;

   function Working_Directory return E_Strings.T
   is
      Result : E_Strings.T;
      CWD    : constant String := GNAT.Directory_Operations.Get_Current_Dir;
   begin
      Result := E_Strings.Copy_String (Str => CWD);

      -- GNAT.Directory_Operations.Get_Current_Dir can return
      -- a trailing separator, which we don't want, so...
      if E_Strings.Get_Length (E_Str => Result) /= 0 and then
        E_Strings.Get_Element
        (E_Str => Result,
         Pos   => E_Strings.Get_Length (E_Str => Result)) = GNAT.OS_Lib.Directory_Separator then

         Result := E_Strings.Section (E_Str     => Result,
                                      Start_Pos => 1,
                                      Length    => E_Strings.Get_Length (E_Str => Result) - 1);
      end if;

      return Result;
   end Working_Directory;

#if Target = "Intel_WinNT" then
   ---------------------------------------------------------------------
   -- We require the pathnames returned from this
   -- function to match those returned by Interfaces.C_Streams.Full_Name
   -- which is used by System.File_IO to detect shared files and
   -- attempts to open the same file twice.  We need this to work
   -- so that circular meta-files can be detected, for example.
   --
   -- On Windows Vista, _fullname can return a _lower_ case
   -- drive letter, while GNAT.OS_Lib.Normalize_Pathname always
   -- returns upper-case, which causes a regression.
   --
   -- This local implementation is therefore needed as a temporary
   -- measure
   ---------------------------------------------------------------------
   function Normalize_Pathname (Name      : in String;
                                Directory : in String) return String
   is
      -- Step 1 - normalize with GNAT.OS_Lib
      C1 : String := GNAT.OS_Lib.Normalize_Pathname (Name           => Name,
                                                     Directory      => Directory,
                                                     Resolve_Links  => True,
                                                     Case_Sensitive => True);

      C_Name : constant String := Name & Ada.Characters.Latin_1.NUL;

      subtype P_String is String (1 .. Interfaces.C_Streams.max_path_len + 1);
      P_Name : P_String := P_String'(others => Ada.Characters.Latin_1.NUL);

      use Ada.Characters.Handling;
   begin
      -- If C1 looks like it has a drive letter on the front
      if C1'Length >= 2 and then
        C1 (2) = ':' and then
        Is_Letter (C1 (1)) then

         -- then Normalize again using Interfaces.C_Streams, relative
         -- to CWD
         Interfaces.C_Streams.full_name (C_Name'Address, P_Name'Address);

         -- if THAT also looks like a drive letter on the front which
         -- is case-insensitively the same as the drive letter returned by
         -- GNAT.OS_Lib - for example if P_Name start with "d:" and C1 starts
         -- with "D:" ...
         if P_Name'Length >= 2 and then
           P_Name (2) = ':' and then
           Is_Letter (P_Name (1)) and then
           To_Lower (P_Name (1)) = To_Lower (C1 (1)) then

            -- ...THEN favour the one returned by C_Streams
            C1 (1) := P_Name (1);
         end if;
      end if;

      return C1;
   end Normalize_Pathname;
#else -- Solaris, Linux, Mac OS X
   -- On all other platforms, just call-through to GNAT.OS_Lib
   function Normalize_Pathname (Name      : in String;
                                Directory : in String) return String
   is
   begin
      return GNAT.OS_Lib.Normalize_Pathname (Name           => Name,
                                             Directory      => Directory,
                                             Resolve_Links  => True,
                                             Case_Sensitive => True);
   end Normalize_Pathname;
#end if;

   function Examiner_Lib_Directory return E_Strings.T is
      DS           : constant Character := GNAT.OS_Lib.Directory_Separator;
      Lib_Rel_Path : constant String    := ".." & DS & "lib" & DS & "spark";
      CN           : constant String    := Ada.Command_Line.Command_Name;
      EN           : GNAT.OS_Lib.String_Access;
      Result       : E_Strings.T;
   begin
      EN := GNAT.OS_Lib.Locate_Exec_On_Path (CN);
      if EN = null then
         Result := E_Strings.Copy_String (Str => Lib_Rel_Path);
      else
         declare
            PN : constant String :=
              Normalize_Pathname
              (Name      => GNAT.Directory_Operations.Dir_Name (EN.all) & DS & Lib_Rel_Path,
               Directory => "");
         begin
            Result := E_Strings.Copy_String (Str => PN);
         end;
      end if;

      GNAT.OS_Lib.Free (EN);
      return Result;
   end Examiner_Lib_Directory;

   function Examiner_SPARK_Lib_Directory return E_Strings.T is
      DS     : constant Character := GNAT.OS_Lib.Directory_Separator;
      Result : E_Strings.T;
   begin
      Result := Examiner_Lib_Directory;
      E_Strings.Append_String (E_Str => Result,
                               Str   => DS & "current");
      return Result;
   end Examiner_SPARK_Lib_Directory;

   procedure Idempotent_Create_Subdirectory
      (Path : in     E_Strings.T;
       Ok   :    out Boolean)
   is
      Name : constant String := E_Strings.Not_SPARK.Get_String (E_Str => Path);

      use GNAT.Directory_Operations;
      use GNAT.OS_Lib;
      use GNAT.IO_Aux;
   begin
      if File_Exists (Name) then
         if Is_Directory (Name) then
            -- A directory called Name already exists - do nothing, and indicate success
            Ok := True;
         else
            -- Something called Name exists, but it's not a directory - error
            Ok := False;
         end if;
      else
         Make_Dir (Name);

         Ok := File_Exists (Name) and then Is_Directory (Name);
      end if;
   exception
      when Directory_Error =>
         Ok := False;
   end Idempotent_Create_Subdirectory;

   function Start_Of_Directory return E_Strings.T
   is
   begin
      return E_Strings.Empty_String;
   end Start_Of_Directory;

   function Directory_Separator return E_Strings.T
   is
      Return_Value : E_Strings.T := E_Strings.Empty_String;
   begin
      E_Strings.Append_Char (E_Str => Return_Value,
                             Ch    => GNAT.OS_Lib.Directory_Separator);
      return Return_Value;
   end Directory_Separator;

   procedure Append_End_Of_Path_If_Needed (D : in out E_Strings.T)
   is
   begin
      if E_Strings.Get_Element
        (E_Str => D,
         Pos   => E_Strings.Get_Length (E_Str => D)) /= GNAT.OS_Lib.Directory_Separator then
         E_Strings.Append_Char (E_Str => D,
                                Ch    => GNAT.OS_Lib.Directory_Separator);
      end if;
   end Append_End_Of_Path_If_Needed;

   procedure Remove_End_Of_Path_If_Present (D : in out E_Strings.T)
   is
   begin
      if E_Strings.Get_Length (E_Str => D) >= 1 and then
        E_Strings.Get_Element
        (E_Str => D,
         Pos   => E_Strings.Get_Length (E_Str => D)) = GNAT.OS_Lib.Directory_Separator then
         D := E_Strings.Section (E_Str     => D,
                                 Start_Pos => 1,
                                 Length    => E_Strings.Get_Length (E_Str => D) - 1);
      end if;
   end Remove_End_Of_Path_If_Present;

   function Is_Readable_File (F : E_Strings.T) return Boolean
   is
      Name : constant String := E_Strings.Not_SPARK.Get_String (E_Str => F);
   begin
      return Name'Length > 0 and then
        GNAT.OS_Lib.Is_Regular_File (Name) and then
        GNAT.OS_Lib.Is_Readable_File (Name);
   end Is_Readable_File;

   function Is_Directory (F : E_Strings.T) return Boolean
   is
      Name : constant String := E_Strings.Not_SPARK.Get_String (E_Str => F);
   begin
      return GNAT.IO_Aux.File_Exists (Name) and then
        GNAT.OS_Lib.Is_Directory (Name);
   end Is_Directory;

   function Base_Name (Path   : E_Strings.T;
                       Suffix : String) return E_Strings.T is
      Str : constant String := GNAT.Directory_Operations.Base_Name
        (SPARK.Ada.Strings.Unbounded.Not_SPARK.To_String (Source => E_Strings.To_Unbounded_String (E_Str => Path)),
         Suffix);
   begin
      return E_Strings.Copy_String (Str => Str);
   end Base_Name;

   procedure Find_Full_File_Name
     (File_Spec      : in     E_Strings.T;
      File_Status    :    out Typ_File_Spec_Status;
      Full_File_Name :    out E_Strings.T)
   is
      -- FUNCTION :
      --
      -- Given a file specification File_Spec, this procedure searches for the file
      -- and, if present, returns the full file name in Full_File_Name. The File_Status
      -- parameter returns one of the following values :
      --
      --   File_Found   - The file denoted by File_Spec was found amd the full filename
      --                 returned in parameter Full_File_Name.
      --   File_Missing - The file denoted by File_Spec could not be found.
      --
      -- NOTE:
      --   File_Invalid is NEVER returned.

      NFN : constant String := Normalize_Pathname
        (Name      => E_Strings.Not_SPARK.Get_String (E_Str => File_Spec),
         Directory => "");
   begin
      Full_File_Name := E_Strings.Copy_String (Str => NFN);
      if GNAT.OS_Lib.Is_Regular_File (NFN) then
         File_Status := File_Found;
      else
         File_Status := File_Missing;
      end if;
   end Find_Full_File_Name;

   function Just_File (Fn  : E_Strings.T;
                       Ext : Boolean) return E_Strings.T
   is
      RS : constant String := E_Strings.Not_SPARK.Get_String (E_Str => Fn);
      ES : constant String := GNAT.Directory_Operations.File_Extension (RS);
      -- Get the Base_Name, stripping any extension that may be there
      BS : constant String := GNAT.Directory_Operations.Base_Name (RS, ES);
      R  : E_Strings.T := E_Strings.Copy_String (Str => BS);
   begin
      -- If required, restore the extension
      if Ext then
         E_Strings.Append_String (E_Str => R,
                                  Str   => ES);
      end if;
      return R;
   end Just_File;

   procedure Check_Extension (Fn  : in out E_Strings.T;
                              Ext : in     E_Strings.T)
   is
      S : constant String := E_Strings.Not_SPARK.Get_String (E_Str => Fn);
      E : constant String := GNAT.Directory_Operations.File_Extension (S);
   begin
      if E = "" then
         if S (S'Last) /= '.' then
            E_Strings.Append_String (E_Str => Fn,
                                     Str   => ".");
         end if;
         E_Strings.Append_Examiner_String (E_Str1 => Fn,
                                           E_Str2 => Ext);
      end if;
   end Check_Extension;

   function Interpret_Relative (File_Name,
                                  Relative_To_Directory : E_Strings.T)
                               return E_Strings.T
   is
      XS    : constant String := E_Strings.Not_SPARK.Get_String (E_Str => File_Name);
      To_YS : constant String := E_Strings.Not_SPARK.Get_String (E_Str => Relative_To_Directory);
      RS    : constant String :=
        Normalize_Pathname
        (Name      => XS,
         Directory => GNAT.Directory_Operations.Dir_Name (To_YS));
   begin
      return E_Strings.Copy_String (Str => RS);
   end Interpret_Relative;

   function Same_File (F1, F2 : E_Strings.T) return Boolean
   is
      S1, S2       : E_Strings.T;
      Stat1, Stat2 : Typ_File_Spec_Status;
   begin
      Find_Full_File_Name (File_Spec      => F1,
                           File_Status    => Stat1,
                           Full_File_Name => S1);
      Find_Full_File_Name (File_Spec      => F2,
                           File_Status    => Stat2,
                           Full_File_Name => S2);
      return (Stat1 /= File_Invalid and Stat2 /= File_Invalid) and then
#if Target = "Intel_WinNT" then
        -- Filenames are case-INSENSITIVE on Windows
        E_Strings.Eq_String (E_Str1 => S1,
                             E_Str2 => S2);
#else -- Solaris, Linux, Mac OS X
        -- Filenames are case-sensitive on Solaris
        E_Strings. Eq_CS_String (E_Str1 => S1,
                                 E_Str2 => S2);
#end if;
   end Same_File;

   function Get_Relative_Path (Full_Path : E_Strings.T;
                               Prefix    : E_Strings.T) return E_Strings.T
   is
      Result : String := E_Strings.Not_SPARK.Get_String (Full_Path);

      function Compare_Char (C1 : Character;
                             C2 : Character) return Boolean
      is
         C1_Tmp : Character := C1;
         C2_Tmp : Character := C2;
      begin
         if C1 = '\' then
            C1_Tmp := '/';
         end if;
         if C2 = '\' then
            C2_Tmp := '/';
         end if;
#if Target = "Intel_WinNT" then
         return Ada.Characters.Handling.To_Lower (C1_Tmp) = Ada.Characters.Handling.To_Lower (C2_Tmp);
#else -- Solaris, Linux, Mac OS X
         return C1_Tmp = C2_Tmp;
#end if;
      end Compare_Char;

   begin
      for I in E_Strings.Lengths range 1 .. E_Strings.Get_Length (E_Str => Prefix) loop
         if Compare_Char (C1 => E_Strings.Get_Element (E_Str => Prefix,
                                                       Pos   => I),
                          C2 => E_Strings.Get_Element (E_Str => Full_Path,
                                                       Pos   => I)) then
            Result (I) := ' ';
         else
            exit;
         end if;
      end loop;
      return E_Strings.Trim (E_Str => E_Strings.Copy_String (Str => Result));
   end Get_Relative_Path;

   function End_Of_Line return E_Strings.T
   is
      S : String (1 .. 1);
   begin
      S (1) := Ada.Characters.Latin_1.LF;
      return E_Strings.Copy_String (Str => S);
   end End_Of_Line;

begin -- initialization part
   null;
end FileSystem;
