gnatcoll_22.0.0_620c2f23/src/gnatcoll-vfs.adb

------------------------------------------------------------------------------
--                             G N A T C O L L                              --
--                                                                          --
--                     Copyright (C) 2003-2019, AdaCore                     --
--                                                                          --
-- This library 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. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE.                            --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Calendar;              use Ada.Calendar;
with Ada.Characters.Handling;   use Ada.Characters.Handling;
with Ada.Numerics.Discrete_Random;
with Ada.Exceptions;            use Ada.Exceptions;
with Ada.Tags;                  use Ada.Tags;
with Ada.Strings.Hash;
with Ada.Strings.Hash_Case_Insensitive;
with Ada.Text_IO;
with Ada.Unchecked_Conversion;

with System;

with GNAT.Heap_Sort;            use GNAT.Heap_Sort;
with GNATCOLL.Utils;            use GNATCOLL.Utils;
with GNATCOLL.IO;               use GNATCOLL.IO;
with GNATCOLL.IO.Remote;        use GNATCOLL.IO.Remote;
with GNATCOLL.Path;             use GNATCOLL.Path;
with GNATCOLL.Remote;           use GNATCOLL.Remote;
with GNATCOLL.Remote.Db;        use GNATCOLL.Remote.Db;
with GNATCOLL.VFS_Types;        use GNATCOLL.VFS_Types;
--  Cannot use GNATCOLL.Traces, or we end up with elaboration cycle

package body GNATCOLL.VFS is

   Empty_String : aliased Filesystem_String := "";

   Handle_Symbolic_Links : Boolean := GNAT.OS_Lib.Directory_Separator /= '\';
   --  If this variable is False, we assume there is never any symbolic link,
   --  and thus we do not spend time resolving them.

   function "+" (S : Filesystem_String) return FS_String;
   function "+" (S : FS_String) return Filesystem_String;
   function "+" (S : FS_String) return String;
   pragma Inline ("+");
   --  FS_String and Filesystem_String are identical in their intent.
   --  We just have a visibility issue as it really should be defined in
   --  VFS's spec, so can't be used by underneath packages (GNATCOLL.IO and
   --  GNATCOLL.Path)

   function "+" is new Ada.Unchecked_Conversion
     (FS_String_Access, Filesystem_String_Access);

   procedure Ensure_Normalized
     (File             : Virtual_File'Class;
      Resolve_Symlinks : Boolean);
   --  Make sure that File.Value.Normalized is filled

   ---------
   -- "+" --
   ---------

   function "+" (S : Filesystem_String) return FS_String is
   begin
      return FS_String (S);
   end "+";

   function "+" (S : FS_String) return Filesystem_String is
   begin
      return Filesystem_String (S);
   end "+";

   function "+" (S : FS_String) return String is
   begin
      return String (S);
   end "+";

   function "+" (S : Filesystem_String) return String is
   begin
      return String (S);
   end "+";

   function "+" (S : String) return Filesystem_String is
   begin
      return Filesystem_String (S);
   end "+";

   ---------
   -- "=" --
   ---------

   function Equal (S1, S2 : Filesystem_String) return Boolean is
   begin
      return Equal (+S1, +S2, Is_Case_Sensitive (Local_FS));
   end Equal;

   ---------
   -- "=" --
   ---------

   overriding function "=" (File1, File2 : Virtual_File) return Boolean is
   begin
      --  Test for the same pointer to actual value (or both null)
      if File1.Value = File2.Value then
         return True;

      --  Test if one of the values is null
      elsif File1.Value = null
        or else File2.Value = null
        or else File1.Value.all'Tag /= File2.Value.all'Tag
      then
         return False;

      --  Finally, we test the normalized paths
      else
         Ensure_Normalized (File1, Resolve_Symlinks => True);
         Ensure_Normalized (File2, Resolve_Symlinks => True);

         --  We also take care of potential trailing dir separator by enforcing
         --  them

         return Equal
           (File1.Value.Get_FS,
            Ensure_Directory
              (File1.Value.Get_FS, File1.Value.Normalized_And_Resolved.all),
            Ensure_Directory
              (File1.Value.Get_FS, File2.Value.Normalized_And_Resolved.all));
      end if;
   end "=";

   ---------
   -- "=" --
   ---------

   function "=" (Left : Writable_File; Right : Writable_File) return Boolean is
      use type GNAT.OS_Lib.File_Descriptor;

   begin
      --  Compare all components except Error for backward compatibility.

      return Left.File = Right.File
        and then Left.Tmp_File = Right.Tmp_File
        and then Left.FD = Right.FD
        and then Left.Append = Right.Append
        and then Left.Success = Right.Success;
   end "=";

   ---------
   -- "<" --
   ---------

   function "<" (File1, File2 : Virtual_File) return Boolean is
      C1, C2         : Character;
      Ind1, Ind2     : Integer;
      Case_Sensitive : Boolean;
   begin
      if File1 = File2 then
         return False;

      elsif File1.Value = null then
         return True;

      elsif File2.Value = null then
         return False;

      elsif Is_Local (File1.Value.all) /= Is_Local (File2.Value.all) then
         return Is_Local (File1.Value.all);

      elsif not Is_Local (File1.Value.all)
        and then Get_Host (File1) /= Get_Host (File2)
      then
         return Get_Host (File1) < Get_Host (File2);

      else
         Case_Sensitive := Is_Case_Sensitive (File1.Value.Get_FS)
           and then Is_Case_Sensitive (File2.Value.Get_FS);

         Ensure_Normalized (File1, Resolve_Symlinks => True);
         Ensure_Normalized (File2, Resolve_Symlinks => True);

         if Case_Sensitive then
            return File1.Value.Normalized_And_Resolved.all <
              File2.Value.Normalized_And_Resolved.all;
         else
            Ind1 := File1.Value.Normalized_And_Resolved'First;
            Ind2 := File2.Value.Normalized_And_Resolved'First;

            for C in 1 .. File1.Value.Normalized_And_Resolved'Length loop
               if Ind2 > File2.Value.Normalized_And_Resolved'Last then
                  return False;
               end if;

               C1 := To_Lower (File1.Value.Normalized_And_Resolved (Ind1));
               C2 := To_Lower (File2.Value.Normalized_And_Resolved (Ind2));

               if C1 < C2 then
                  return True;
               elsif C1 > C2 then
                  return False;
               end if;

               Ind1 := Ind1 + 1;
               Ind2 := Ind2 + 1;
            end loop;

            return True;
         end if;
      end if;
   end "<";

   ------------
   -- Create --
   ------------

   function Create
     (Full_Filename : Filesystem_String;
      Host          : String := Local_Host;
      Normalize     : Boolean := False) return Virtual_File
   is
      function Internal_Get_Path (FS : FS_Type) return FS_String;
      --  Get Full_Filename according to Normalize setting

      -----------------------
      -- Internal_Get_Path --
      -----------------------

      function Internal_Get_Path (FS : FS_Type) return FS_String is
      begin
         if not Normalize then
            return +Full_Filename;
         end if;

         if GNATCOLL.Path.Is_Absolute_Path (FS, +Full_Filename) then
            return GNATCOLL.Path.Normalize (FS, +Full_Filename);
         else
            declare
               Full_Path : constant Virtual_File :=
                  Get_Current_Dir (Host => Host) / Full_Filename;
            begin
               return GNATCOLL.Path.Normalize (FS,
                                               +Full_Path.Full_Name);
            end;
         end if;
      end Internal_Get_Path;

   begin
      if Full_Filename = "" then
         return No_File;
      end if;

      if Host = Local_Host then
         return (Ada.Finalization.Controlled with
                 Value => GNATCOLL.IO.Native.Create
                   (Internal_Get_Path (GNATCOLL.Path.Local_FS)));
      else
         return (Ada.Finalization.Controlled with
                 Value => GNATCOLL.IO.Remote.Create
                   (Host, +Full_Filename, Normalize));
      end if;
   end Create;

   ----------------------
   -- Create_From_UTF8 --
   ----------------------

   function Create_From_UTF8
     (Full_Filename : String;
      Host          : String := Local_Host;
      Normalize     : Boolean := False) return Virtual_File is
   begin
      if Host = Local_Host then
         return Create
           (+GNATCOLL.IO.Native.Codec.From_UTF8 (Full_Filename),
            Normalize => Normalize);
      else
         return Create
           (+GNATCOLL.IO.Remote.Codec.From_UTF8 (Full_Filename), Host,
            Normalize => Normalize);
      end if;
   end Create_From_UTF8;

   ----------------------
   -- Create_From_Base --
   ----------------------

   function Create_From_Base
     (Base_Name : Filesystem_String;
      Base_Dir  : Filesystem_String := "";
      Host      : String := Local_Host) return Virtual_File
   is
      FS : FS_Type;
   begin
      if Host = Local_Host then
         FS := Local_FS;
      else
         FS := Shell_FS (Get_Server (Host).all);
      end if;

      declare
         The_Name : constant FS_String := Path.From_Unix (FS, +Base_Name);
         The_Dir  : constant FS_String := Path.From_Unix (FS, +Base_Dir);
      begin
         if Is_Absolute_Path (FS, The_Name) then
            return Create (+The_Name, Host);

         elsif The_Dir /= "" then
            return Create
              (+(Path.Ensure_Directory (FS, The_Dir) & The_Name), Host);

         else
            return Create_From_Dir
              (Get_Current_Dir (Host), +The_Name);
         end if;
      end;
   end Create_From_Base;

   ---------------------
   -- Create_From_Dir --
   ---------------------

   function Create_From_Dir
     (Dir       : Virtual_File;
      Base_Name : Filesystem_String;
      Normalize : Boolean := False) return Virtual_File
   is
   begin
      if Dir.Value = null then
         raise VFS_Invalid_File_Error;
      end if;

      Dir.Ensure_Directory;

      return
        (Ada.Finalization.Controlled with
         Dispatching_Create
           (Ref       => Dir.Value,
            Full_Path =>
               FS_String (Dir.Full_Name (Normalize).all) &
               From_Unix (Dir.Value.Get_FS, +Base_Name)));
   end Create_From_Dir;

   ------------------
   -- Error_String --
   ------------------

   function Error_String
     (Self : Writable_File) return Ada.Strings.Unbounded.Unbounded_String is
   begin
      return Self.Error;
   end Error_String;

   --------------------
   -- Locate_On_Path --
   --------------------

   function Locate_On_Path
     (Base_Name : Filesystem_String;
      Host      : String := Local_Host) return Virtual_File
   is
      Name : GNAT.OS_Lib.String_Access;
      Ret  : Virtual_File;
      use type GNAT.OS_Lib.String_Access;

   begin
      if Host = Local_Host then
         if Is_Absolute_Path (Local_FS, +Base_Name) then
            return Create (Base_Name);
         end if;

         Name := GNAT.OS_Lib.Locate_Exec_On_Path (+Base_Name);

         if Name = null then
            return No_File;
         else
            Ret := Create (+Name.all);
            GNAT.OS_Lib.Free (Name);
            return Ret;
         end if;

      else
         declare
            Int : constant GNATCOLL.IO.File_Access :=
                    GNATCOLL.IO.Remote.Locate_On_Path (Host, +Base_Name);
         begin
            if Int = null then
               return No_File;
            else
               return (Ada.Finalization.Controlled with Int);
            end if;
         end;
      end if;
   end Locate_On_Path;

   -----------------------
   -- Get_Tmp_Directory --
   -----------------------

   function Get_Tmp_Directory (Host : String := Local_Host) return Virtual_File
   is
   begin
      if Host = Local_Host then
         return (Ada.Finalization.Controlled with
                 GNATCOLL.IO.Native.Get_Tmp_Directory);
      else
         return (Ada.Finalization.Controlled with
                 GNATCOLL.IO.Remote.Get_Tmp_Directory (Host));
      end if;
   end Get_Tmp_Directory;

   ------------------------
   -- Get_Home_Directory --
   ------------------------

   function Get_Home_Directory
     (Host : String := Local_Host) return Virtual_File
   is
   begin
      if Host = Local_Host then
         return (Ada.Finalization.Controlled with
                 GNATCOLL.IO.Native.Home_Dir);
      else
         return (Ada.Finalization.Controlled with
                 GNATCOLL.IO.Remote.Home_Dir (Host));
      end if;
   end Get_Home_Directory;

   ------------------------
   -- Get_Logical_Drives --
   ------------------------

   function Get_Logical_Drives
     (Host : String := Local_Host) return File_Array_Access
   is
      function Get_IO_List return GNATCOLL.IO.File_Array;
      --  Get the IO list depending on Host

      -----------------
      -- Get_IO_List --
      -----------------

      function Get_IO_List return GNATCOLL.IO.File_Array is
      begin
         if Host = Local_Host then
            return GNATCOLL.IO.Native.Get_Logical_Drives;
         else
            return GNATCOLL.IO.Remote.Get_Logical_Drives (Host);
         end if;
      end Get_IO_List;

      List : constant GNATCOLL.IO.File_Array := Get_IO_List;
      Ret  : constant File_Array_Access := new File_Array (1 .. List'Length);

   begin
      for J in List'Range loop
         Ret (J - List'First + 1) :=
           (Ada.Finalization.Controlled with
            List (J));
         Ret (J - List'First + 1).Value.Kind := Directory;
      end loop;

      return Ret;
   end Get_Logical_Drives;

   ---------------------
   -- Get_Current_Dir --
   ---------------------

   function Get_Current_Dir
     (Host : String := Local_Host) return Virtual_File
   is
      Ret : Virtual_File;
   begin
      if Host = Local_Host then
         Ret := (Ada.Finalization.Controlled with
                 GNATCOLL.IO.Native.Current_Dir);
      else
         Ret := (Ada.Finalization.Controlled with
                 GNATCOLL.IO.Remote.Current_Dir (Host));
      end if;

      Ret.Value.Kind := Directory;
      return Ret;
   end Get_Current_Dir;

   ---------------
   -- Base_Name --
   ---------------

   function Base_Name
     (File      : Virtual_File;
      Suffix    : Filesystem_String := "";
      Normalize : Boolean := False)
      return Filesystem_String is
   begin
      if File.Value = null then
         return "";
      end if;

      if Normalize then
         Ensure_Normalized (File, Resolve_Symlinks => True);
         return +Base_Name
           (File.Value.Get_FS,
            File.Value.Normalized_And_Resolved.all,
            +Suffix);
      else
         return +Base_Name (File.Value.Get_FS, File.Value.Full.all, +Suffix);
      end if;
   end Base_Name;

   -------------------
   -- Base_Dir_Name --
   -------------------

   function Base_Dir_Name (File : Virtual_File) return Filesystem_String is
   begin
      if File.Value = null then
         return "";
      end if;

      return +Base_Dir_Name (File.Value.Get_FS, File.Value.Full.all);
   end Base_Dir_Name;

   ---------------
   -- Full_Name --
   ---------------

   function Full_Name
     (File : Virtual_File; Normalize : Boolean := False)
      return Filesystem_String is
   begin
      return File.Full_Name (Normalize).all;
   end Full_Name;

   ---------------
   -- Full_Name --
   ---------------

   function Full_Name
     (File          : Virtual_File;
      Normalize     : Boolean := False;
      Resolve_Links : Boolean := False)
      return Cst_Filesystem_String_Access is
   begin
      if File.Value = null then
         return Empty_String'Access;

      elsif File.Value.Full /= null and then Normalize then
         Ensure_Normalized (File, Resolve_Links);
         if Resolve_Links then
            return Cst_Filesystem_String_Access
              (+File.Value.Normalized_And_Resolved.all'Access);
         else
            return Cst_Filesystem_String_Access
              (+File.Value.Normalized.all'Access);
         end if;

      elsif File.Value.Full = null
        and then Get_Host (File) /= Local_Host
      then
         GNATCOLL.IO.Remote.Ensure_Initialized
           (GNATCOLL.IO.Remote.Remote_File_Access (File.Value));
         return Cst_Filesystem_String_Access (+File.Value.Full.all'Access);

      else
         return Cst_Filesystem_String_Access (+File.Value.Full.all'Access);
      end if;
   end Full_Name;

   --------------------
   -- Full_Name_Hash --
   --------------------

   function Full_Name_Hash
     (Key : Virtual_File) return Ada.Containers.Hash_Type
   is
      F : FS_Type;
   begin
      if Key.Value = null then
         return 0;
      end if;

      Ensure_Normalized (Key, Resolve_Symlinks => True);

      --  We also take care of potential trailing dir separator by enforcing
      --  them. The goal is that we have the same hash whenever "=" returns
      --  True, so that we can instantiate hash tables by using "=" for the
      --  equivalent key function

      F := Key.Value.Get_FS;
      if Is_Case_Sensitive (F) then
         return Ada.Strings.Hash
           (+Ensure_Directory (F, Key.Value.Normalized_And_Resolved.all));
      else
         return Ada.Strings.Hash_Case_Insensitive
           (+Ensure_Directory (F, Key.Value.Normalized_And_Resolved.all));
      end if;
   end Full_Name_Hash;

   --------------
   -- Dir_Name --
   --------------

   function Dir_Name (File : Virtual_File) return Filesystem_String is
   begin
      if File.Value = null then
         return "";
      end if;

      return +Dir_Name (File.Value.Get_FS, File.Value.Full.all);
   end Dir_Name;

   ---------
   -- Dir --
   ---------

   function Dir (File : Virtual_File) return Virtual_File is
   begin
      if File.Value = null then
         return VFS.No_File;
      end if;

      if Is_Dir_Name (File.Value.Get_FS, File.Value.Full.all) then
         return File;
      else
         return
           (Ada.Finalization.Controlled with
            Value => Dispatching_Create
              (File.Value,
               Dir_Name
                 (File.Value.Get_FS, File.Value.Full.all)));
      end if;
   end Dir;

   -----------------------
   -- Display_Full_Name --
   -----------------------

   function Display_Full_Name
     (File      : Virtual_File;
      Normalize : Boolean := False) return String is
   begin
      if File.Value = null then
         return "";

      else
         return File.Value.To_UTF8
           (FS_String (File.Full_Name (Normalize).all));
      end if;
   end Display_Full_Name;

   -----------------------
   -- Display_Base_Name --
   -----------------------

   function Display_Base_Name
     (File   : Virtual_File;
      Suffix : Filesystem_String := "") return String is
   begin
      if File.Value = null then
         return "";

      else
         return File.Value.To_UTF8 (+File.Base_Name (Suffix));
      end if;
   end Display_Base_Name;

   ---------------------
   -- Locale_Dir_Name --
   ---------------------

   function Display_Dir_Name (File : Virtual_File) return String is
   begin
      if File.Value = null then
         return "";

      else
         return File.Value.To_UTF8 (+File.Dir_Name);
      end if;
   end Display_Dir_Name;

   ---------------------------
   -- Display_Base_Dir_Name --
   ---------------------------

   function Display_Base_Dir_Name (File : Virtual_File) return String is
   begin
      if File.Value = null then
         return "";
      else
         return File.Value.To_UTF8 (+File.Base_Dir_Name);
      end if;
   end Display_Base_Dir_Name;

   --------------------------
   -- Unix_Style_Full_Name --
   --------------------------

   function Unix_Style_Full_Name
     (File         : Virtual_File;
      Cygwin_Style : Boolean := False;
      Normalize    : Boolean := False;
      Casing       : Boolean := False) return Filesystem_String
   is
      FS : FS_Type;

      function Auto_Case (Str : FS_String) return Filesystem_String;
      function Auto_Case (Str : FS_String) return Filesystem_String is
      begin
         if not Casing or else Is_Case_Sensitive (FS) then
            return +Str;
         else
            return +To_Lower (+Str);
         end if;
      end Auto_Case;

   begin
      if File.Value = null then
         return "";
      else
         FS := File.Value.Get_FS;

         if Normalize then
            return Auto_Case (To_Unix
              (FS,
               +Full_Name
                 (File, Normalize => Normalize, Resolve_Links => True).all,
               Cygwin_Style));
         else
            return Auto_Case (To_Unix (FS, File.Value.Full.all, Cygwin_Style));
         end if;
      end if;
   end Unix_Style_Full_Name;

   -------------------
   -- Relative_Path --
   -------------------

   function Relative_Path
     (File : Virtual_File;
      From : Virtual_File) return Filesystem_String
   is
   begin
      --  Obviously, we need from to be a directory...
      if not Is_Directory (From) then
         return File.Full_Name;
      end if;

      if From.Value = null
        or else File.Value = null
        or else File.Value'Tag /= From.Value'Tag
      then
         return File.Full_Name;
      end if;

      return Filesystem_String (Relative_Path
        (File.Value.Get_FS,
         Ref  => FS_String (From.Full_Name.all),
         Path => FS_String (File.Full_Name.all)));
   end Relative_Path;

   ----------------
   -- Has_Suffix --
   ----------------

   function Has_Suffix
     (File : Virtual_File; Suffix : Filesystem_String) return Boolean is
   begin
      return File.Value /= null
        and then File.Full_Name.all'Length >= Suffix'Length
        and then Equal
          (File.Value.Get_FS,
           File.Value.Full
             (File.Value.Full'Last - Suffix'Length + 1
                .. File.Value.Full'Last),
           +Suffix);
   end Has_Suffix;

   ---------------
   -- To_Remote --
   ---------------

   function To_Remote
     (File : Virtual_File; To_Host : String) return Virtual_File
   is
   begin
      if File.Value = null then
         return No_File;
      end if;

      if File.Get_Host = To_Host then
         return File;
      end if;

      if not Is_Configured (To_Host) then
         raise VFS_Remote_Config_Error;
      end if;

      declare
         Server : constant Server_Access := Get_Server (To_Host);
         Local  : Virtual_File;
         Remote : Virtual_File := No_File;

      begin
         for J in 1 .. Nb_Mount_Points (Server.Nickname) loop
            Local := Create (+Get_Mount_Point_Local_Root (Server.Nickname, J));

            if Local.Is_Parent (File) then
               Remote := Create
                 (+Get_Mount_Point_Host_Root (Server.Nickname, J),
                  To_Host);
               exit;
            end if;
         end loop;

         if Remote = No_File then
            --  Simple conversion
            return Convert (File, To_Host);
         else
            return Convert (File, Local, Remote);
         end if;
      end;
   end To_Remote;

   --------------
   -- To_Local --
   --------------

   function To_Local (File : Virtual_File) return Virtual_File is
   begin
      if File.Value = null then
         return No_File;
      end if;

      if File.Is_Local then
         return File;
      end if;

      if not Is_Configured (File.Get_Host) then
         raise VFS_Remote_Config_Error;
      end if;

      declare
         Server : constant Server_Access := Get_Server (File.Get_Host);
         Local  : Virtual_File := No_File;
         Remote : Virtual_File;

      begin
         for J in 1 .. Nb_Mount_Points (Server.Nickname) loop
            Remote := Create
              (+Get_Mount_Point_Host_Root (Server.Nickname, J),
               File.Get_Host);

            if Remote.Is_Parent (File) then
               Local := Create
                 (+Get_Mount_Point_Local_Root (Server.Nickname, J));
               exit;
            end if;
         end loop;

         if Local = No_File then
            --  Simple conversion
            return Convert (File, Local_Host);
         else
            return Convert (File, Remote, Local);
         end if;
      end;
   end To_Local;

   ------------
   -- To_Arg --
   ------------

   function To_Arg
     (File : Virtual_File;
      Host : String := Local_Host) return GNAT.Strings.String_Access
   is
      Host_File : Virtual_File;
   begin
      if Host /= File.Get_Host then
         if File.Get_Host /= Local_Host then
            Host_File := File.To_Local;
         else
            Host_File := File;
         end if;

         if Host /= Local_Host then
            Host_File := Host_File.To_Remote (Host);
         end if;

         return new String'(String (Host_File.Full_Name.all));
      end if;

      return new String'(String (File.Full_Name.all));
   end To_Arg;

   -------------
   -- Convert --
   -------------

   function Convert
     (File : Virtual_File; To_Host : String) return Virtual_File
   is
   begin
      if File.Value = null then
         return No_File;
      end if;

      --  Create always handles both paths in Unix form, or paths in Host's
      --  form. So we first translate the path to unix (possible whatever the
      --  current path format is), then it's up to Create to correctly format
      --  the path.
      return Create
        (+To_Unix
           (File.Value.Get_FS, FS_String (File.Full_Name.all)), To_Host);
   end Convert;

   -------------
   -- Convert --
   -------------

   function Convert
     (File     : Virtual_File;
      From_Dir : Virtual_File;
      To_Dir   : Virtual_File) return Virtual_File
   is
   begin
      if File.Value = null
        or else From_Dir.Value = null
        or else To_Dir.Value = null
      then
         return No_File;
      end if;

      if From_Dir.Value.Get_FS /= To_Dir.Value.Get_FS then
         return Create_From_Dir
           (To_Dir,
            +To_Unix (File.Value.Get_FS, +File.Relative_Path (From_Dir)));
      else
         return Create_From_Dir
           (To_Dir,
            File.Relative_Path (From_Dir));
      end if;
   end Convert;

   --------------------
   -- Unchecked_Free --
   --------------------

   procedure Unchecked_Free (Arr : in out File_Array_Access) is
      procedure Internal is new Ada.Unchecked_Deallocation
        (File_Array, File_Array_Access);
   begin
      Internal (Arr);
   end Unchecked_Free;

   --------------
   -- Is_Local --
   --------------

   function Is_Local (File : Virtual_File) return Boolean is
   begin
      return File.Value = null
        or else File.Value.all in GNATCOLL.IO.Native.Native_File_Record'Class;
   end Is_Local;

   ----------
   -- Host --
   ----------

   function Get_Host (File : Virtual_File) return String is
   begin
      if Is_Local (File) then
         return Local_Host;
      else
         return GNATCOLL.IO.Remote.Get_Host
           (Remote_File_Record (File.Value.all)'Access);
      end if;
   end Get_Host;

   ---------------------
   -- Is_Regular_File --
   ---------------------

   function Is_Regular_File (File : Virtual_File) return Boolean is
      Ret : Boolean;
   begin
      if File.Value = null then
         return False;

      elsif File.Value.all not in GNATCOLL.IO.Native.Native_File_Record'Class
        and then File.Value.Kind /= Unknown
      --  Only use cache for remote files
      then
         return File.Value.Kind = GNATCOLL.IO.File;

      else
         Ret := File.Value.Is_Regular_File;

         if Ret then
            File.Value.Kind := GNATCOLL.IO.File;
         end if;

         return Ret;
      end if;
   end Is_Regular_File;

   ----------
   -- Size --
   ----------

   function Size (File : Virtual_File) return Long_Integer is
   begin
      if File.Value = null then
         return 0;
      else
         return File.Value.Size;
      end if;
   end Size;

   ------------
   -- Rename --
   ------------

   procedure Rename
     (File      : Virtual_File;
      Full_Name : Virtual_File;
      Success   : out Boolean) is
   begin
      if File.Value = null
        or else Full_Name.Value = null
        or else File.Value'Tag /= Full_Name.Value'Tag
      then
         Success := False;
      else
         Rename (File.Value, Full_Name.Value, Success);

         if Success then
            Full_Name.Value.Kind := File.Value.Kind;
            File.Value.Kind := Unknown;
         end if;

      end if;
   end Rename;

   ----------
   -- Copy --
   ----------

   procedure Copy
     (File        : Virtual_File;
      Target_Name : Filesystem_String;
      Success     : out Boolean) is
   begin
      if File.Value = null then
         Success := False;
      end if;

      if Is_Directory (File) then
         File.Value.Copy_Dir (+Target_Name, Success);

      else
         File.Value.Copy (+Target_Name, Success);
      end if;
   end Copy;

   ------------
   -- Delete --
   ------------

   procedure Delete
     (File    : Virtual_File;
      Success : out Boolean) is
   begin
      if File.Value = null then
         Success := False;
      else
         File.Value.Delete (Success);
      end if;
   end Delete;

   -----------------
   -- Is_Readable --
   -----------------

   function Is_Readable (File : Virtual_File) return Boolean is
   begin
      return File.Value /= null and then File.Value.Is_Readable;
   end Is_Readable;

   -----------------
   -- Is_Writable --
   -----------------

   function Is_Writable (File : Virtual_File) return Boolean is
   begin
      return File.Value /= null and then File.Value.Is_Writable;
   end Is_Writable;

   ------------------
   -- Is_Directory --
   ------------------

   function Is_Directory (VF : Virtual_File) return Boolean is
      Ret : Boolean;
   begin
      if VF.Value = null then
         return False;

      elsif VF.Value.all not in GNATCOLL.IO.Native.Native_File_Record'Class
        and then VF.Value.Kind /= Unknown
      --  Only use cache for remote files
      then
         return VF.Value.Kind = Directory;

      else
         Ret := VF.Value.Is_Directory;

         if Ret then
            VF.Ensure_Directory;
            VF.Value.Kind := Directory;
         end if;

         return Ret;
      end if;
   end Is_Directory;

   ----------------------
   -- Is_Symbolic_Link --
   ----------------------

   function Is_Symbolic_Link (File : Virtual_File) return Boolean is
   begin
      return File.Value /= null
        and then File.Value.Is_Symbolic_Link;
   end Is_Symbolic_Link;

   ----------------------
   -- Is_Absolute_Path --
   ----------------------

   function Is_Absolute_Path (File : Virtual_File) return Boolean is
   begin
      return File.Value /= null
        and then Is_Absolute_Path (File.Value.Get_FS, File.Value.Full.all);
   end Is_Absolute_Path;

   --------------------
   -- File_Extension --
   --------------------

   function File_Extension
     (File      : Virtual_File;
      Normalize : Boolean := False) return Filesystem_String is
   begin
      if File.Value = null then
         return "";
      else
         return Filesystem_String
           (File_Extension
              (File.Value.Get_FS, FS_String (File.Full_Name (Normalize).all)));
      end if;
   end File_Extension;

   ---------------
   -- Read_File --
   ---------------

   function Read_File
     (File : Virtual_File) return GNAT.Strings.String_Access
   is
   begin
      if File.Value = null then
         return null;

      elsif File.Value.Kind = Directory then
         return null;

      else
         return File.Value.Read_Whole_File;
      end if;
   end Read_File;

   ---------------
   -- Read_File --
   ---------------

   function Read_File (File : Virtual_File) return GNATCOLL.Strings.XString is
   begin
      if File.Value = null
         or else File.Value.Kind = Directory
      then
         return GNATCOLL.Strings.Null_XString;
      else
         return File.Value.Read_Whole_File;
      end if;
   end Read_File;

   ----------------
   -- Write_File --
   ----------------

   function Write_File
     (File   : Virtual_File;
      Append : Boolean := False) return Writable_File
   is
      use type GNAT.OS_Lib.File_Descriptor;
      W  : Writable_File;

      function Temporary_File (From : Virtual_File) return Virtual_File;
      --  Return a temporary file on the host as From.
      --  Return No_File if we couldn't create one.

      --------------------
      -- Temporary_File --
      --------------------

      function Temporary_File (From : Virtual_File) return Virtual_File is
         use GNAT.OS_Lib;

         subtype Lowercase is Character range 'a' .. 'z';
         package Random_Char is new Ada.Numerics.Discrete_Random (Lowercase);

         Gen     : Random_Char.Generator;

         Tmp_Dir : constant Virtual_File := Get_Tmp_Directory (From.Get_Host);
         Pid_Int : constant Integer := Pid_To_Integer (Current_Process_Id);
         Pid     : constant Filesystem_String := +Integer'Image (Pid_Int);

      begin
         Random_Char.Reset (Gen);

         --  Make 10 attempts to find a random name that isn't already taken
         for J in 1 .. 10 loop
            declare
               R   : constant Filesystem_String (1 .. 8) :=
                 (others => Random_Char.Random (Gen));
               Temp : Virtual_File;
            begin
               --  Bake in "vfs" and the PID in the temporary file name,
               --  potentially useful for development and debugging.
               Temp := Create_From_Dir
                 (Tmp_Dir, "vfs-" & Pid (Pid'First + 1 .. Pid'Last) & "-" & R);

               if not Temp.Is_Regular_File then
                  --  A file with that name doesn't already exist? use it.
                  return Temp;
               end if;
            end;
         end loop;
         --  ... If all these files existed, return an error
         return No_File;
      end Temporary_File;

   begin
      if File.Value = null then
         return Invalid_File;
      end if;

      W.File    := File;
      W.Append  := Append;
      W.Success := True;

      if not Append or else not File.Is_Regular_File then
         --  Not appending, or appending to a file that doesn't exist
         --  yet: write to a temporary file first.

         W.Tmp_File := Temporary_File (File);

         --  Check whether we could actually create the temporary file
         if W.Tmp_File = No_File then
            return X : Writable_File := Invalid_File do
               X.Error := Ada.Strings.Unbounded.To_Unbounded_String
                 ("Could not create a temporary file");
            end return;
         end if;

         W.Tmp_File.Value.Open_Write
           (Append => False, FD => W.FD, Error => W.Error);

      else
         W.Tmp_File := No_File;

         --  append-mode, and the file already exists.
         File.Value.Open_Write
           (Append => True, FD => W.FD, Error => W.Error);
      end if;

      if W.FD = GNAT.OS_Lib.Invalid_FD then
         return X : Writable_File := Invalid_File do
            X.Error := W.Error;
         end return;
      else
         return W;
      end if;
   end Write_File;

   -----------
   -- Write --
   -----------

   procedure Write
     (File : in out Writable_File;
      Str  : String)
   is
      Written : aliased Integer;

   begin
      if File.Success then
         Written := GNAT.OS_Lib.Write (File.FD, Str'Address, Str'Length);
         File.Success := Written = Str'Length;
         if not File.Success then
            File.Error := Ada.Strings.Unbounded.To_Unbounded_String
              ("Disk full");
         end if;

         if Written > 0 then
            --  File has been overwritten on the disk anyway
            if File.Tmp_File /= No_File then
               File.Tmp_File.Value.Kind := GNATCOLL.IO.File;
            else
               File.File.Value.Kind := GNATCOLL.IO.File;
            end if;
         end if;
      end if;
   end Write;

   -----------
   -- Write --
   -----------

   procedure Write
     (File : in out Writable_File;
      Str  : chars_ptr)
   is
      Written : aliased Integer;
      Len     : Integer;

      function To_Address is
        new Ada.Unchecked_Conversion (chars_ptr, System.Address);
   begin
      if File.Success then
         Len := Integer (Strlen (Str));
         Written := GNAT.OS_Lib.Write (File.FD, To_Address (Str), Len);
         File.Success := Written = Len;
         if not File.Success then
            File.Error := Ada.Strings.Unbounded.To_Unbounded_String
              ("Disk full");
         end if;
         if Written > 0 then
            File.File.Value.Kind := GNATCOLL.IO.File;
         end if;
      end if;
   end Write;

   -----------
   -- Close --
   -----------

   procedure Close (File : in out Writable_File) is
      use Ada.Strings.Unbounded;
      Norm : Virtual_File;
      Success : Boolean;

      --  We'll need to force the resolution of symbolic links,
      --  since we never want to transform a link into a regular
      --  file (which among other things breaks support for CM Synergy)
      Save_Handle_Symbolic_Links : constant Boolean := Handle_Symbolic_Links;
   begin
      if File.Success then
         if File.Tmp_File /= No_File then
            File.Tmp_File.Value.Close (File.FD, File.Success);
            if not File.Success then
               File.Error := To_Unbounded_String ("close() failed");
            else
               --  Look past symbolic links. We do not want to impact the
               --  normalized name saved in File, so we need to use local
               --  copies.
               Handle_Symbolic_Links := True;
               Norm := Create (File.File.Full_Name.all);
               Norm := Create
                 (Norm.Full_Name
                    (Normalize => True, Resolve_Links => True).all);
               Handle_Symbolic_Links := Save_Handle_Symbolic_Links;

               --  Preserve permissions on the file
               Copy_File_Permissions
                  (From    => Norm.Value,
                   To      => File.Tmp_File.Value,
                   Success => Success);
               --  ??? We ignore the value of success here. It is not a
               --  critical error, however, and we want to continue the
               --  process of saving here. It would be nice to log this,
               --  but we cannot use Traces in this package.

               --  We use to delete explicitly Norm. But in fact this is not a
               --  good idea, since the directory might allow us to delete the
               --  file (or not), but not to recreate it afterwards, as seem to
               --  be the case with CM Synergy.

               File.Tmp_File.Rename (Norm, File.Success);

               if not File.Success then
                  --  Renaming failed. It might be because it could not
                  --  remove the original (read-only directory for instance)
                  --  so let's try with a simple copy instead
                  File.Tmp_File.Copy
                     (Norm.Full_Name (Normalize => True).all, File.Success);
                  if File.Success then
                     File.Tmp_File.Delete (Success);
                     --  ignore Success, that's fine if the temp file is
                     --  still there.
                  else
                     File.Error := To_Unbounded_String
                       (+("Copy failed from " & File.Tmp_File.Full_Name.all
                        & " to " & Norm.Full_Name.all));
                  end if;
               end if;
            end if;

         else
            File.File.Value.Close (File.FD, File.Success);
         end if;
      end if;

      if not File.Success then
         raise Ada.Text_IO.Use_Error with "Error while writing to the file"
           & (if File.Error /= Null_Unbounded_String
              then " (" & To_String (File.Error) & ")"
              else "");
      end if;
   end Close;

   ------------------
   -- Set_Writable --
   ------------------

   procedure Set_Writable (File : VFS.Virtual_File; Writable : Boolean) is
   begin
      if File.Value = null then
         raise VFS_Invalid_File_Error;
      end if;

      File.Value.Set_Writable (Writable);
   end Set_Writable;

   ------------------
   -- Set_Readable --
   ------------------

   procedure Set_Readable (File : VFS.Virtual_File; Readable : Boolean) is
   begin
      if File.Value = null then
         raise VFS_Invalid_File_Error;
      end if;

      File.Value.Set_Readable (Readable);
   end Set_Readable;

   ---------------------
   -- File_Time_Stamp --
   ---------------------

   function File_Time_Stamp
     (File : Virtual_File) return Ada.Calendar.Time is
   begin
      if File.Value = null then
         return GNATCOLL.Utils.No_Time;
      end if;

      return File.Value.File_Time_Stamp;
   end File_Time_Stamp;

   ----------------------
   -- Ensure_Directory --
   ----------------------

   procedure Ensure_Directory (Dir : Virtual_File) is
      Full : FS_String_Access;
   begin
      if Dir.Value /= null then
         if not Is_Dir_Name (Dir.Value.Get_FS, Dir.Value.Full.all) then
            Full := new FS_String'
              (Ensure_Directory (Dir.Value.Get_FS, Dir.Value.Full.all));
            Free (Dir.Value.Full);
            Dir.Value.Full := Full;
         end if;

         if Dir.Value.Normalized /= null
           and then not Is_Dir_Name
             (Dir.Value.Get_FS, Dir.Value.Normalized.all)
         then
            Full := new FS_String'
              (Ensure_Directory
                 (Dir.Value.Get_FS, Dir.Value.Normalized.all));

            if Dir.Value.Normalized /= Dir.Value.Normalized_And_Resolved then
               Free (Dir.Value.Normalized_And_Resolved);
            end if;
            Free (Dir.Value.Normalized);
            Dir.Value.Normalized_And_Resolved := null;

            Dir.Value.Normalized := Full;
         end if;
      end if;
   end Ensure_Directory;

   -----------------------
   -- Ensure_Normalized --
   -----------------------

   procedure Ensure_Normalized
     (File             : Virtual_File'Class;
      Resolve_Symlinks : Boolean) is
   begin
      if File.Value = null then
         return;
      end if;

      if File.Value.Normalized = null then
         File.Value.Normalized := new FS_String'
           (Path.Normalize (File.Value.Get_FS, File.Value.Full.all));
      end if;

      if Resolve_Symlinks then
         if Handle_Symbolic_Links then
            GNATCOLL.IO.Resolve_Symlinks (File.Value);
         else
            if File.Value.Normalized_And_Resolved = null then
               File.Value.Normalized_And_Resolved := File.Value.Normalized;
            end if;
         end if;
      end if;
   end Ensure_Normalized;

   --------------------
   -- Normalize_Path --
   --------------------

   procedure Normalize_Path
     (File             : Virtual_File;
      Resolve_Symlinks : Boolean := False)
   is
   begin
      if File.Value = null then
         return;
      end if;

      Ensure_Normalized (File, Resolve_Symlinks);

      Free (File.Value.Full);

      if Resolve_Symlinks then
         File.Value.Full :=
           new FS_String'(File.Value.Normalized_And_Resolved.all);
      else
         File.Value.Full := new FS_String'(File.Value.Normalized.all);
      end if;
   end Normalize_Path;

   --------------
   -- Get_Root --
   --------------

   function Get_Root (File : Virtual_File) return Virtual_File is
   begin
      if File.Value = null then
         return No_File;
      end if;

      return
        (Ada.Finalization.Controlled with
         Dispatching_Create
           (File.Value,
            Get_Root (File.Value.Get_FS, File.Value.Full.all)));
   end Get_Root;

   ----------------
   -- Get_Parent --
   ----------------

   function Get_Parent (Dir : Virtual_File) return Virtual_File is
   begin
      if Dir.Value = null then
         return No_File;
      end if;

      declare
         Parent : constant FS_String :=
                    Get_Parent (Dir.Value.Get_FS, Dir.Value.Full.all);
      begin
         if Parent = "" then
            return No_File;
         else
            return
              (Ada.Finalization.Controlled with
               Dispatching_Create (Dir.Value, Parent));
         end if;
      end;
   end Get_Parent;

   -------------
   -- Sub_Dir --
   -------------

   function Sub_Dir
     (Dir : Virtual_File; Name : Filesystem_String) return Virtual_File
   is
      New_Dir : Virtual_File;
   begin
      Ensure_Directory (Dir);
      New_Dir :=
        (Ada.Finalization.Controlled with
         Dispatching_Create
           (Dir.Value,
            GNATCOLL.Path.Path
              (Dir.Value.Get_FS, "",
               FS_String (Dir.Full_Name.all), FS_String (Name))));
      Ensure_Directory (New_Dir);

      if Is_Directory (New_Dir) and then True then
         return New_Dir;
      else
         return No_File;
      end if;
   end Sub_Dir;

   ----------------
   -- Change_Dir --
   ----------------

   procedure Change_Dir (Dir : Virtual_File) is
      Success : Boolean;
      pragma Unreferenced (Success);
   begin
      if Dir.Value = null then
         Raise_Exception (VFS_Directory_Error'Identity, "Dir is No_File");
      end if;

      Success := Dir.Value.Change_Dir;
   end Change_Dir;

   --------------
   -- Make_Dir --
   --------------

   procedure Make_Dir (Dir : Virtual_File; Recursive : Boolean := True) is
      Result : Boolean;
   begin
      if Dir.Value = null then
         Raise_Exception (VFS_Directory_Error'Identity, "Dir is No_File");
      end if;

      --  If Dir already exists and is a directory, then return
      if Is_Directory (Dir) then
         return;
      end if;

      Result := Dir.Value.Make_Dir (Recursive);

      if not Result then
         Dir.Value.Kind := Unknown;
         Raise_Exception
           (VFS_Directory_Error'Identity, "Dir cannot be created");
      else
         Dir.Value.Kind := Directory;
      end if;

   exception
      when E : others =>
         Raise_Exception
           (VFS_Directory_Error'Identity, Exception_Message (E));
   end Make_Dir;

   ----------------
   -- Remove_Dir --
   ----------------

   procedure Remove_Dir
     (Dir       : Virtual_File;
      Recursive : Boolean := False;
      Success   : out Boolean) is
   begin
      if Dir.Value = null then
         raise VFS_Directory_Error;
      end if;

      Dir.Value.Remove_Dir (Recursive, Success);
      if Success then
         Dir.Value.Kind := Unknown;
      end if;
   end Remove_Dir;

   --------------
   -- Read_Dir --
   --------------

   function Read_Dir
     (Dir    : Virtual_File;
      Filter : Read_Dir_Filter := All_Files) return File_Array_Access
   is
      F_Array  : File_Array_Access;
      Tmp_File : Virtual_File;

   begin
      if Dir.Value = null then
         Raise_Exception (VFS_Directory_Error'Identity, "Dir is No_File");
      end if;

      Ensure_Directory (Dir);

      if not Is_Directory (Dir) then
         Raise_Exception
           (VFS_Directory_Error'Identity, "Dir is not a directory");
      end if;

      declare
         List : GNAT.Strings.String_List :=
                  Dir.Value.Read_Dir
                    (Dirs_Only  => Filter = Dirs_Only,
                     Files_Only => Filter = Files_Only);
      begin
         F_Array := new File_Array (1 .. List'Length);

         for J in List'Range loop
            Tmp_File := Dir.Create_From_Dir (+List (J).all);

            case Filter is
               when Dirs_Only =>
                  Tmp_File.Value.Kind := Directory;

               when Files_Only =>
                  Tmp_File.Value.Kind := File;

               when others =>
                  null;

            end case;

            F_Array (F_Array'First + J - List'First) := Tmp_File;
            GNAT.Strings.Free (List (J));
         end loop;
      end;

      return F_Array;

   exception
      when E : others =>
         Unchecked_Free (F_Array);
         Raise_Exception
           (VFS_Directory_Error'Identity,
            Exception_Message (E));
   end Read_Dir;

   ------------------------
   -- Read_Dir_Recursive --
   ------------------------

   function Read_Dir_Recursive
      (Dir       : Virtual_File;
       Extension : Filesystem_String := "";
       Filter    : Read_Dir_Filter := All_Files) return File_Array_Access
   is
      Result : File_Array_Access;

      procedure Internal (Directory : Virtual_File);
      --  process a directory recursively

      procedure Internal (Directory : Virtual_File) is
         Files : File_Array_Access := Directory.Read_Dir (Filter => All_Files);
      begin
         if Files = null then
            return;
         end if;

         for F in Files'Range loop
            declare
               B : constant Filesystem_String := Files (F).Base_Name;
            begin
               if B /= "." and then B /= ".." then
                  if Extension = ""
                     or else Files (F).File_Extension = Extension
                  then
                     case Filter is
                     when Dirs_Only =>
                        if Files (F).Is_Directory then
                           Append (Result, Files (F));
                        end if;
                     when Files_Only =>
                        if Files (F).Is_Regular_File then
                           Append (Result, Files (F));
                        end if;
                     when All_Files =>
                        Append (Result, Files (F));
                     end case;
                  end if;

                  if Files (F).Is_Directory then
                     Internal (Files (F));
                  end if;
               end if;
            end;
         end loop;

         Unchecked_Free (Files);
      end Internal;

   begin
      if Dir.Is_Directory then
         Internal (Dir);
      end if;
      return Result;
   end Read_Dir_Recursive;

   --------------------------
   -- Read_Files_From_Dirs --
   --------------------------

   function Read_Files_From_Dirs
      (Dirs : File_Array) return File_Array_Access
   is
      Ret    : File_Array_Access := null;
      Files  : array (Dirs'Range) of File_Array_Access;
      Length : Natural := 0;
      Idx    : Natural;
   begin
      for J in Dirs'Range loop
         begin
            Files (J) := Read_Dir (Dirs (J), Files_Only);

            if Files (J) /= null then
               Length := Length + Files (J)'Length;
            end if;

         exception
            when VFS_Directory_Error =>
               Files (J) := null;
         end;
      end loop;

      if Length = 0 then
         return null;
      else
         Ret := new File_Array (1 .. Length);
         Idx := Ret'First;

         for J in Files'Range loop
            if Files (J) /= null then
               Ret (Idx .. Idx + Files (J)'Length - 1) := Files (J).all;
               Idx := Idx + Files (J)'Length;
               Unchecked_Free (Files (J));
            end if;
         end loop;

         return Ret;
      end if;
   end Read_Files_From_Dirs;

   --------------
   -- Open_Dir --
   --------------

   function Open_Dir (Dir : Virtual_File) return Virtual_Dir is
      VDir : Virtual_Dir;
   begin
      if Dir.Value = null then
         return Invalid_Dir;
      end if;

      VDir.File := Dir;
      VDir.Files_List := Read_Dir (Dir);

      if VDir.Files_List /= null then
         VDir.Current := VDir.Files_List'First - 1;
      end if;

      Dir.Value.Kind := Directory;
      return VDir;

   exception
      when VFS_Directory_Error =>
         return Invalid_Dir;
   end Open_Dir;

   ----------
   -- Read --
   ----------

   procedure Read
     (VDir : in out Virtual_Dir;
      File :    out Virtual_File) is
   begin
      if VDir.Files_List /= null
        and then VDir.Current < VDir.Files_List'Last
      then
         VDir.Current := VDir.Current + 1;
         File := VDir.Files_List (VDir.Current);
      else
         File := No_File;
      end if;
   end Read;

   -----------
   -- Close --
   -----------

   procedure Close (VDir : in out Virtual_Dir) is
   begin
      if VDir.Files_List /= null then
         Unchecked_Free (VDir.Files_List);
      end if;

      VDir := Invalid_Dir;
   end Close;

   --------------
   -- Finalize --
   --------------

   overriding procedure Finalize (File : in out Virtual_File) is
      Value : GNATCOLL.IO.File_Access := File.Value;
   begin
      File.Value := null;  --  Make Finalize idempotent
      if Value /= null then
         Unref (Value);
      end if;
   end Finalize;

   ------------
   -- Adjust --
   ------------

   overriding procedure Adjust (File : in out Virtual_File) is
   begin
      if File.Value /= null then
         Ref (File.Value);
      end if;
   end Adjust;

   ---------------
   -- Is_Parent --
   ---------------

   function Is_Parent (Parent, Child : Virtual_File) return Boolean is
   begin
      if Parent.Value = null
        or else Child.Value = null
        or else Parent.Value'Tag /= Child.Value'Tag
      then
         return False;
      end if;

      Ensure_Normalized (Parent, Resolve_Symlinks => True);
      Ensure_Normalized (Child, Resolve_Symlinks => True);

      if Parent.Value.Normalized_And_Resolved'Length >
        Child.Value.Normalized_And_Resolved'Length
      then
         return False;
      end if;

      return Equal
        (Parent.Value.Get_FS,
         Parent.Value.Normalized_And_Resolved.all,
         Child.Value.Normalized_And_Resolved
           (Child.Value.Normalized_And_Resolved'First ..
              Child.Value.Normalized_And_Resolved'First +
                Parent.Value.Normalized_And_Resolved'Length - 1));
   end Is_Parent;

   ----------
   -- Sort --
   ----------

   procedure Sort (Files : in out File_Array) is
      --  ??? Right now, this sorts only on the full name. Do we want to
      --  provide other choices for sorting ?

      procedure Xchg (Op1, Op2 : Natural);
      --  Exchanges two items in the array

      function Lt (Op1, Op2 : Natural) return Boolean;
      --  Return True if the first item is to be sorted before the second

      ----------
      -- Xchg --
      ----------

      procedure Xchg (Op1, Op2 : Natural) is
         Buffer : Virtual_File;
      begin
         Buffer := Files (Files'First - 1 + Op1);
         Files (Files'First - 1 + Op1) := Files (Files'First - 1 + Op2);
         Files (Files'First - 1 + Op2) := Buffer;
      end Xchg;

      --------
      -- Lt --
      --------

      function Lt (Op1, Op2 : Natural) return Boolean is
      begin
         return Files (Files'First - 1 + Op1) <
           Files (Files'First - 1 + Op2);
      end Lt;

   begin
      Sort (Files'Length, Xchg'Unrestricted_Access, Lt'Unrestricted_Access);
   end Sort;

   ------------
   -- Append --
   ------------

   procedure Append (Files : in out File_Array_Access; F : Virtual_File) is
   begin
      Append (Files, File_Array'(1 => F));
   end Append;

   ------------
   -- Append --
   ------------

   procedure Append (Files : in out File_Array_Access; F : File_Array) is
      Tmp : File_Array_Access;
   begin
      if Files = null then
         Files := new File_Array'(F);
      else
         Tmp := new File_Array (1 .. Files'Length + F'Length);
         Tmp (1 .. Files'Length) := Files.all;
         Tmp (Files'Length + 1 .. Tmp'Last) := F;
         Unchecked_Free (Files);
         Files := Tmp;
      end if;
   end Append;

   -------------
   -- Prepend --
   -------------

   procedure Prepend (Files : in out File_Array_Access; F : File_Array) is
      Tmp : File_Array_Access;
   begin
      if Files = null then
         Files := new File_Array'(F);
      else
         Tmp := new File_Array (1 .. Files'Length + F'Length);
         Tmp (1 + F'Length .. Tmp'Length) := Files.all;
         Tmp (1 .. F'Length) := F;
         Unchecked_Free (Files);
         Files := Tmp;
      end if;
   end Prepend;

   ------------
   -- Remove --
   ------------

   procedure Remove (Files : in out File_Array_Access; F : Virtual_File) is
      Tmp : File_Array_Access;
   begin
      for J in Files'Range loop
         if Files (J) = F then
            for K in J + 1 .. Files'Last loop
               Files (K - 1) := Files (K);
            end loop;

            Tmp := new File_Array'(Files (Files'First .. Files'Last - 1));
            Unchecked_Free (Files);
            Files := Tmp;

            return;
         end if;
      end loop;
   end Remove;

   -------------
   -- To_Path --
   -------------

   function To_Path (Paths : File_Array) return Filesystem_String is
      Length : Natural := 0;
   begin
      if Paths'Length = 0 then
         return "";
      end if;

      for J in Paths'Range loop
         Length := Length + Paths (J).Full_Name.all'Length;
      end loop;

      Length := Length + Paths'Length - 1;

      declare
         Ret : Filesystem_String (1 .. Length);
         Idx : Natural := Ret'First;
      begin
         for J in Paths'Range loop
            Ret (Idx .. Idx + Paths (J).Full_Name.all'Length - 1) :=
              Paths (J).Full_Name.all;
            Idx := Idx + Paths (J).Full_Name.all'Length;

            if J /= Paths'Last then
               Ret (Idx) := GNAT.OS_Lib.Path_Separator;
               Idx := Idx + 1;
            end if;
         end loop;

         return Ret;
      end;
   end To_Path;

   ---------------
   -- From_Path --
   ---------------

   function From_Path (Path : Filesystem_String) return File_Array is
      Ret  : File_Array_Access;
      Last : Natural := Path'First;
   begin
      for J in Path'First .. Path'Last loop
         --  ??? Should define Path_Separator in FS (system-dependent)
         if Path (J) = GNAT.OS_Lib.Path_Separator then
            if Last < J then
               Append (Ret, Create (Path (Last .. J - 1)));
            end if;

            Last := J + 1;
         end if;
      end loop;

      if Last <= Path'Last then
         Append (Ret, Create (Path (Last .. Path'Last)));
      end if;

      if Ret = null then
         return (1 .. 0 => <>);
      end if;

      declare
         Final : constant File_Array := Ret.all;
      begin
         Unchecked_Free (Ret);

         return Final;
      end;
   end From_Path;

   --------------------
   -- Locate_On_Path --
   --------------------

   function Locate_On_Path
     (Base_Name : Filesystem_String;
      Path      : File_Array) return Virtual_File
   is
      File : Virtual_File;
   begin
      for J in Path'Range loop
         if Path (J) /= No_File then
            File := Create_From_Dir (Path (J), Base_Name);

            if Is_Regular_File (File) then
               return File;
            end if;

            File := Create_From_Dir
              (Path (J), Base_Name & (+Exe_Extension (Path (J).Value.Get_FS)));

            if Is_Regular_File (File) then
               return File;
            end if;
         end if;
      end loop;

      return No_File;
   end Locate_On_Path;

   --------------------------
   -- Greatest_Common_Path --
   --------------------------

   function Greatest_Common_Path
     (L : GNATCOLL.VFS.File_Array) return Virtual_File
   is
   begin
      if L'Length = 0 then
         return GNATCOLL.VFS.No_File;
      end if;

      declare
         Greatest_Prefix : Virtual_File := L (L'First);
         Root            : constant Virtual_File := Get_Root (Greatest_Prefix);
      begin
         for J in L'First + 1 .. L'Last loop
            --  Loop until GP is a parent of the current File
            while not Greatest_Prefix.Is_Parent (L (J)) loop
               --  If not a parent, and already at root, then there is no
               --  greatest prefix.
               if Greatest_Prefix = Root then
                  return No_File;
               end if;

               Greatest_Prefix := Get_Parent (Greatest_Prefix);
            end loop;
         end loop;

         return Greatest_Prefix;
      end;
   end Greatest_Common_Path;

   -------------------------
   -- Locate_Regular_File --
   -------------------------

   function Locate_Regular_File
     (File_Name : Filesystem_String;
      Path      : File_Array) return Virtual_File
   is
      F : Virtual_File;
   begin
      for J in Path'Range loop
         F := Create_From_Dir (Path (J), File_Name);

         if F.Is_Regular_File then
            return F;
         end if;
      end loop;

      return No_File;
   end Locate_Regular_File;

   ----------------------------
   -- Symbolic_Links_Support --
   ----------------------------

   procedure Symbolic_Links_Support (Active : Boolean) is
   begin
      Handle_Symbolic_Links := Active;
   end Symbolic_Links_Support;

   ----------
   -- Join --
   ----------

   function Join
      (Self : Virtual_File; File : Virtual_File) return Virtual_File is
   begin
      return Create_From_Dir (Self, File.Full_Name.all);
   end Join;

   ----------
   -- Join --
   ----------

   function Join
      (Self : Virtual_File; Path : Filesystem_String) return Virtual_File is
   begin
      return Create_From_Dir (Self, Path);
   end Join;

   ---------
   -- "/" --
   ---------

   function "/"
      (Self : Virtual_File; File : Virtual_File) return Virtual_File is
   begin
      return Create_From_Dir (Self, File.Full_Name.all);
   end "/";

   ---------
   -- "/" --
   ---------

   function "/"
      (Self : Virtual_File; Path : Filesystem_String) return Virtual_File is
   begin
      return Create_From_Dir (Self, Path);
   end "/";

   ---------
   -- "/" --
   ---------

   function "/"
      (Dir : Filesystem_String; File : Virtual_File) return Virtual_File is
   begin
      return Create_From_Dir (Create (Dir), File.Full_Name.all);
   end "/";

end GNATCOLL.VFS;