-------------------------------------------------------------------------------
--
--  <STRONG>Copyright &copy; 2001, 2002 by Thomas Wolf.</STRONG>
--  <BLOCKQUOTE>
--    This piece of software 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 2, or (at your option)
--    any later version. This software is distributed in the hope that it will
--    be useful, but <EM>without any warranty</EM>; without even the implied
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
--    See the GNU General Public License for  more details. You should have
--    received a copy of the GNU General Public License with this distribution,
--    see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--    USA.
--  </BLOCKQUOTE>
--  <BLOCKQUOTE>
--    As a special exception from the GPL, if other files instantiate generics
--    from this unit, or you link this unit with other files to produce an
--    executable, this unit does not by itself cause the resulting executable
--    to be covered by the GPL. This exception does not however invalidate any
--    other reasons why the executable file might be covered by the GPL.
--  </BLOCKQUOTE>
--
--  <AUTHOR>
--    Thomas Wolf  (TW) <E_MAIL>
--  </AUTHOR>
--
--  <PURPOSE>
--    Operations for manipulating file names. The package is intended for
--    use on Windows or Unix systems. Upon elaboration, it tries to figure
--    out the host operating system by examining the @PATH@ environment
--    variable: if that contains Windows-looking pathes (i.e., a '\' is found
--    before a any '/'), it assumes it's being used on Windows. If, on the
--    other hand, it finds a '/' first, it assumes Unix. If it finds neither,
--    it uses @GNAT.Os_Lib.Directory_Separator@ as its directory separator.
--    (If you intend to use this package on a non-GNAT system, you'll have
--    to change the body of this package as appropriate.)
--
--    All operations in this package are pur string manipulation operations.
--    There are no file system operations involved.
--  </PURPOSE>
--
--  <NOT_TASK_SAFE>
--
--  <NO_STORAGE>
--
--  <HISTORY>
--    19-MAR-2002   TW  Initial version.
--    03-MAY-2002   TW  Added 'Drive' and 'Node'; various minor corrections.
--  </HISTORY>
-------------------------------------------------------------------------------

pragma License (Modified_GPL);

with Util.Environment;
with Util.Strings;

with GNAT.OS_Lib;

pragma Elaborate_All (Util.Environment);
pragma Elaborate_All (Util.Strings);

package body Util.Pathes is

   --  Syntax:
   --
   --  Windows:
   --     [(\\Node\{\}|Drive_Letter:{\})]{Name\{\}}[Base_Name][.Extension]
   --     where Name . and .. have special meanings.
   --
   --  Unix:
   --     [/{/}]{Name/{/}][Base_Name][.Extension]
   --     where Name . and .. have special meanings.
   --
   --  VMS:
   --     [Disk:]["["[Name]{.Dir_Name}"]"][Base_Name][.Extension][;Version]
   --     where Dir_Name . and "" have special meaning
   --
   --  Mac:
   --     Not sure. I think it went like this:
   --     {Name:}[Base_Name][.Extension]
   --     where Name : has a special meaning.
   --
   --  VMS and Mac are not done yet!

   use Util.Strings;

   ----------------------------------------------------------------------------
   --  Internal operations:

   function Determine_Host_Separator
     return Character
   is
      Path : constant String  := Util.Environment.Safe_Get ("PATH");
      I    : Natural := First_Index (Path, '\');
      J    : Natural := First_Index (Path, '/');
   begin
      if I = 0 then I := Natural'Last; end if;
      if J = 0 then J := Natural'Last; end if;
      if I < J then
         return '\';
      elsif J < I then
         return '/';
      else
         return GNAT.OS_Lib.Directory_Separator;
      end if;
   end Determine_Host_Separator;

   Dir_Sep : constant Character := Determine_Host_Separator;

   function Node_End
     (Full_Name : in String;
      Separator : in Character)
     return Natural
   is
   begin
      --  Needs revision for VMS!
      if (Separator = '\' or else Separator = '/') and then
         Full_Name'Last > Full_Name'First + 1 and then
         Full_Name (Full_Name'First) = Separator and then
         Full_Name (Full_Name'First + 1) = Separator
      then
         declare
            I : constant Natural :=
              First_Index (Full_Name
                             (Full_Name'First + 2 .. Full_Name'Last),
                           Separator);
         begin
            if I = 0 then
               return Full_Name'Last;
            else
               return I;
            end if;
         end;
      end if;
      return 0;
   end Node_End;

   function Drive_End
     (Full_Name : in String;
      Separator : in Character)
     return Natural
   is
      I : Natural := Node_End (Full_Name, Separator);
   begin
      if I = 0 then
         I := Full_Name'First;
      else
         if Full_Name (I) /= Separator then
            --  Only a node name!
            return 0;
         end if;
         I := I + 1;
      end if;
      if Separator = '\' and then
         I + 1 <= Full_Name'Last and then
         Is_In (Letters, Full_Name (I)) and then
         Full_Name (I + 1) = ':'
      then
         return I + 1;
      end if;
      --  Needs revision for VMS!
      return 0;
   end Drive_End;

   function Path_End
     (Full_Name : in String;
      Separator : in Character)
     return Natural
   is
      I : constant Natural := Node_End (Full_Name, Separator);
   begin
      if I > 0 and then Full_Name (I) /= Separator then
         return I;
      end if;
      return Natural'Max (Last_Index (Full_Name, Separator),
                          Drive_End (Full_Name, Separator));
   end Path_End;

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

   function Directory_Separator
     return Character
   is
   begin
      return Dir_Sep;
   end Directory_Separator;

   function Extension
     (Full_Name : in String;
      Separator : in Character := Util.Pathes.Directory_Separator)
     return String
   is
      I : Natural := Path_End (Full_Name, Separator);
      J : Natural;
   begin
      if I = 0 then I := Full_Name'First; else I := I + 1; end if;
      J := Last_Index (Full_Name (I .. Full_Name'Last), '.');
      if J <= I then
         return "";
      else
         return Full_Name (J + 1 .. Full_Name'Last);
      end if;
   end Extension;

   function Name
     (Full_Name : in String;
      Separator : in Character := Directory_Separator)
     return String
   is
      I : constant Natural := Path_End (Full_Name, Separator);
   begin
      if I = 0 then return Full_Name; end if;
      return Full_Name (I + 1 .. Full_Name'Last);
   end Name;

   function Base_Name
     (Full_Name : in String;
      Separator : in Character := Directory_Separator)
     return String
   is
      I : Natural := Path_End (Full_Name, Separator);
      J : Natural;
   begin
      if I = 0 then I := Full_Name'First; else I := I + 1; end if;
      J := Last_Index (Full_Name (I .. Full_Name'Last), '.');
      if J <= I then
         --  Also handles cases like ".cshrc".
         return Full_Name (I .. Full_Name'Last);
      else
         return Full_Name (I .. J - 1);
      end if;
   end Base_Name;

   function Path
     (Full_Name : in String;
      Separator : in Character := Directory_Separator)
     return String
   is
      I : constant Natural := Path_End (Full_Name, Separator);
   begin
      if I = 0 then return ""; end if;
      return Full_Name (Full_Name'First .. I);
   end Path;

   function Drive
     (Full_Name : in String;
      Separator : in Character := Directory_Separator)
     return String
   is
      I : Natural := Node_End (Full_Name, Separator);
   begin
      if I = 0 then I := Full_Name'First; else I := I + 1; end if;
      return
        Full_Name (I .. Drive_End (Full_Name (I .. Full_Name'Last),
                                   Separator));
   end Drive;

   function Has_Drive
     (Full_Name : in String;
      Separator : in Character := Directory_Separator)
     return Boolean
   is
      I : Natural := Node_End (Full_Name, Separator);
   begin
      if I = 0 then I := Full_Name'First; else I := I + 1; end if;
      return Drive_End (Full_Name (I .. Full_Name'Last), Separator) > 0;
   end Has_Drive;

   function Node
     (Full_Name : in String;
      Separator : in Character := Directory_Separator)
     return String
   is
   begin
      return Full_Name (Full_Name'First .. Node_End (Full_Name, Separator));
   end Node;

   function Has_Node
     (Full_Name : in String;
      Separator : in Character := Directory_Separator)
     return Boolean
   is
   begin
      return Node_End (Full_Name, Separator) > 0;
   end Has_Node;

   function Normalize
     (Path      : in String;
      Separator : in Character := Directory_Separator)
     return String
   is
   begin
      if Path'Last < Path'First then return '.' & Separator; end if;
      if Drive_End (Path, Separator) = Path'Last then
         return Path;
      elsif Path (Path'Last) = Separator then
         return Path;
      else
         return Path & Separator;
      end if;
   end Normalize;

   function Parent
     (Path      : in String;
      Separator : in Character := Directory_Separator)
     return String
   is

      function Up
        (Path      : in String;
         Separator : in Character)
        return String
      is
         --  'Path' is a cleaned-up path!

         I : Natural;

      begin
         if Path'Last = Path'First and then Path (Path'First) = Separator then
            raise Path_Error; --  Root in an absolute path
         elsif Path = '.' & Separator then
            return ".." & Separator;
         end if;
         I := Last_Index (Path (Path'First .. Path'Last - 1), Separator);
         if I = 0 then
            --  "something/", return "./"
            if Path (Path'First .. Path'Last - 1) = ".." then
               --  Oops, we already had "../": return "../../".
               return Path & Path;
            elsif Path (Path'First .. Path'Last - 1) = "." then
               --  We had "./", return "./../".
               return Path & ".." & Separator;
            else
               return '.' & Separator;
            end if;
         else
            if Path (I + 1 .. Path'Last - 1) = ".." then
               --  We have only a sequence of "../": add one more.
               return Path & ".." & Separator;
            else
               return Path (Path'First .. I);
            end if;
         end if;
      end Up;

      P    : constant String := Clean (Path, Separator);
      I, J : Natural;

   begin
      I := Node_End (P, Separator);
      if I = 0 then I := P'First; else I := I + 1; end if;
      J := Drive_End (P (I .. P'Last), Separator);
      if J > 0 then
         if J = P'Last then
            return P & ".." & Separator;
         else
            return P (P'First .. J) &
                   Up (P (J + 1 .. P'Last), Separator);
         end if;
      elsif I > 0 then
         if P (I) = Separator then
            return P (P'First .. I - 1) &
                   Up (P (I .. P'Last), Separator);
         else
            --  Only a node name: cannot get the parent, for relative pathes
            --  are not allowed.
            raise Path_Error;
         end if;
      end if;
      --  Neither node name nor drive:
      return Up (P,  Separator);
   end Parent;

   function Clean
     (Full_Name : in String;
      Separator : in Character := Directory_Separator)
     return String
   is

      function Clean_It
        (Path      : in String;
         Separator : in Character)
        return String
      is
         Result : String (1 .. Path'Length + 1);
         K      : Natural;
      begin
         K := Result'First;
         for I in Path'Range loop
            Result (K) := Path (I);
            if Path (I) = Separator then
               if K > Result'First + 2 and then
                  Result (K - 1) = '.' and then
                  Result (K - 2) = '.' and then
                  Result (K - 3) = Separator
               then
                  if K = Result'First + 3 then
                     --  A path cannot start with "/../"!
                     raise Path_Error;
                  end if;
                  declare
                     J : constant Natural :=
                       Last_Index (Result (Result'First .. K - 4),
                                   Separator);
                  begin
                     if J > 0 then
                        if Result (J + 1 .. K - 4) = ".." then
                           --  We have "../../../", which is legal and can
                           --  occur only at the beginning!
                           null;
                        else
                           K := J;
                        end if;
                     else
                        if K - 4 = Result'First and then
                           Result (Result'First) = '.'
                        then
                           --  We have "./../", which should become "../".
                           Result (Result'First + 1) := '.';
                           Result (Result'First + 2) := Separator;
                           K := Result'First + 2;
                        elsif Result (Result'First .. K - 4) = ".." then
                           --  We have "../../" at the beginning!
                           null;
                        else
                           --  We have "something/../", which should
                           --  become "./".
                           Result (Result'First) := '.';
                           Result (Result'First + 1) := Separator;
                           K := Result'First + 1;
                        end if;
                     end if;
                  end;
               elsif K > Result'First + 1 and then
                     Result (K - 1) = '.' and then
                     Result (K - 2) = Separator
               then
                  K := K - 2;
               elsif K > Result'First and then
                     Result (K - 1) = Separator
               then
                  --  Eliminate extraneous separators.
                  K := K - 1;
               end if;
            end if;
            K := K + 1;
         end loop;
         K := K - 1;
         if K >= Result'First and then Result (K) /= Separator then
            K := K + 1;
            Result (K) := Separator;
         end if;
         return Result (Result'First .. K);
      end Clean_It;

      I, J : Natural;

   begin
      I := Node_End (Full_Name, Separator);
      if I > 0 then
         if Full_Name (I) /= Separator then
            --  Only a node name, without terminating separator:
            return Full_Name & Separator;
         end if;
         --  Skip multiple separators:
         J := I + 1;
         while J <= Full_Name'Last and then Full_Name (J) = Separator loop
            J := J + 1;
         end loop;
         if J > I + 1 then
            return Clean (Full_Name (Full_Name'First .. I) &
                          Full_Name (J .. Full_Name'Last));
         end if;
      end if;
      J := Drive_End (Full_Name, Separator);
      if J > 0 then
         return Full_Name (Full_Name'First .. J) &
                Clean_It (Full_Name (J + 1 .. Full_Name'Last), Separator);
      end if;
      if I > 0 then
         return Full_Name (Full_Name'First .. I - 1) &
                Clean_It (Full_Name (I .. Full_Name'Last), Separator);
      end if;
      return Clean_It (Full_Name, Separator);
   end Clean;

   function Is_Absolute_Path
     (Name      : in String;
      Separator : in Character := Directory_Separator)
     return Boolean
   is
   begin
      if Name'Last < Name'First then return False; end if;
      if Separator = ':' then
         --  Mac? It's been a while, but if I remember correctly, it went
         --  like this:
         return Name (Name'First) /= ':';
      else
         --  Not Mac, i.e. Windows or Unix.
         if Name (Name'First) = Separator then
            return True;
         end if;
         if Drive_End (Name, Separator) > 0 then
            return True;
         end if;
      end if;
      return False;
   end Is_Absolute_Path;

   function Concat
     (Path      : in String;
      File_Name : in String;
      Separator : in Character := Directory_Separator)
     return String
   is
   begin
      if Path'Last      < Path'First      then return File_Name; end if;
      if File_Name'Last < File_Name'First then return Path;      end if;
      if Is_Absolute_Path (File_Name, Separator) then
         raise Path_Error;
      end if;
      return Normalize (Path, Separator) & File_Name;
   end Concat;

   function Replace_File_Name
     (Full_Name : in String;
      File_Name : in String;
      Separator : in Character := Directory_Separator)
     return String
   is
   begin
      return Concat (Path (Full_Name, Separator), File_Name, Separator);
   end Replace_File_Name;

   function Replace_Extension
     (Full_Name : in String;
      Extension : in String;
      Separator : in Character := Directory_Separator)
     return String
   is
      J : Natural := Path_End (Full_Name, Separator);
   begin
      if Full_Name'Last < Full_Name'First or else J = Full_Name'Last then
         raise Path_Error;
      end if;
      declare
         I : constant Natural := Last_Index (Full_Name, '.');
      begin
         if J = 0 then J := Full_Name'First; else J := J + 1; end if;
         if I <= J then
            return Full_Name & '.' & Extension;
         else
            return Full_Name (Full_Name'First .. I) & Extension;
         end if;
      end;
   end Replace_Extension;

end Util.Pathes;
