Subversion Repositories openrisc_2011-10-31

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

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

--                                                                          --

--                                                                          --

--                         GNAT RUN-TIME COMPONENTS                         --

--                         GNAT RUN-TIME COMPONENTS                         --

--                                                                          --

--                                                                          --

--                      A D A . D I R E C T O R I E S                       --

--                      A D A . D I R E C T O R I E S                       --

--                                                                          --

--                                                                          --

--                                 B o d y                                  --

--                                 B o d y                                  --

--                                                                          --

--                                                                          --

--          Copyright (C) 2004-2009, Free Software Foundation, Inc.         --

--          Copyright (C) 2004-2009, Free Software Foundation, Inc.         --

--                                                                          --

--                                                                          --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- GNAT is free software;  you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --

-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --

--                                                                          --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

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

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

--                                                                          --

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

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

with Ada.Calendar;               use Ada.Calendar;

with Ada.Calendar;               use Ada.Calendar;

with Ada.Calendar.Formatting;    use Ada.Calendar.Formatting;

with Ada.Calendar.Formatting;    use Ada.Calendar.Formatting;

with Ada.Directories.Validity;   use Ada.Directories.Validity;

with Ada.Directories.Validity;   use Ada.Directories.Validity;

with Ada.Strings.Maps;

with Ada.Strings.Maps;

with Ada.Strings.Fixed;

with Ada.Strings.Fixed;

with Ada.Strings.Unbounded;      use Ada.Strings.Unbounded;

with Ada.Strings.Unbounded;      use Ada.Strings.Unbounded;

with Ada.Unchecked_Conversion;

with Ada.Unchecked_Conversion;

with Ada.Unchecked_Deallocation;

with Ada.Unchecked_Deallocation;

with Ada.Characters.Handling;    use Ada.Characters.Handling;

with Ada.Characters.Handling;    use Ada.Characters.Handling;

with System.CRTL;                use System.CRTL;

with System.CRTL;                use System.CRTL;

with System.OS_Lib;              use System.OS_Lib;

with System.OS_Lib;              use System.OS_Lib;

with System.Regexp;              use System.Regexp;

with System.Regexp;              use System.Regexp;

with System;

with System;

package body Ada.Directories is

package body Ada.Directories is

   Filename_Max : constant Integer := 1024;

   Filename_Max : constant Integer := 1024;

   --  1024 is the value of FILENAME_MAX in stdio.h

   --  1024 is the value of FILENAME_MAX in stdio.h

   type Dir_Type_Value is new System.Address;

   type Dir_Type_Value is new System.Address;

   --  This is the low-level address directory structure as returned by the C

   --  This is the low-level address directory structure as returned by the C

   --  opendir routine.

   --  opendir routine.

   No_Dir : constant Dir_Type_Value := Dir_Type_Value (System.Null_Address);

   No_Dir : constant Dir_Type_Value := Dir_Type_Value (System.Null_Address);

   Dir_Separator : constant Character;

   Dir_Separator : constant Character;

   pragma Import (C, Dir_Separator, "__gnat_dir_separator");

   pragma Import (C, Dir_Separator, "__gnat_dir_separator");

   --  Running system default directory separator

   --  Running system default directory separator

   Dir_Seps : constant Ada.Strings.Maps.Character_Set :=

   Dir_Seps : constant Ada.Strings.Maps.Character_Set :=

                Ada.Strings.Maps.To_Set ("/\");

                Ada.Strings.Maps.To_Set ("/\");

   --  UNIX and DOS style directory separators

   --  UNIX and DOS style directory separators

   Max_Path : Integer;

   Max_Path : Integer;

   pragma Import (C, Max_Path, "__gnat_max_path_len");

   pragma Import (C, Max_Path, "__gnat_max_path_len");

   --  The maximum length of a path

   --  The maximum length of a path

   type Search_Data is record

   type Search_Data is record

      Is_Valid      : Boolean := False;

      Is_Valid      : Boolean := False;

      Name          : Unbounded_String;

      Name          : Unbounded_String;

      Pattern       : Regexp;

      Pattern       : Regexp;

      Filter        : Filter_Type;

      Filter        : Filter_Type;

      Dir           : Dir_Type_Value := No_Dir;

      Dir           : Dir_Type_Value := No_Dir;

      Entry_Fetched : Boolean := False;

      Entry_Fetched : Boolean := False;

      Dir_Entry     : Directory_Entry_Type;

      Dir_Entry     : Directory_Entry_Type;

   end record;

   end record;

   --  The current state of a search

   --  The current state of a search

   Empty_String : constant String := (1 .. 0 => ASCII.NUL);

   Empty_String : constant String := (1 .. 0 => ASCII.NUL);

   --  Empty string, returned by function Extension when there is no extension

   --  Empty string, returned by function Extension when there is no extension

   procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);

   procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);

   procedure Close (Dir : Dir_Type_Value);

   procedure Close (Dir : Dir_Type_Value);

   function File_Exists (Name : String) return Boolean;

   function File_Exists (Name : String) return Boolean;

   --  Returns True if the named file exists

   --  Returns True if the named file exists

   procedure Fetch_Next_Entry (Search : Search_Type);

   procedure Fetch_Next_Entry (Search : Search_Type);

   --  Get the next entry in a directory, setting Entry_Fetched if successful

   --  Get the next entry in a directory, setting Entry_Fetched if successful

   --  or resetting Is_Valid if not.

   --  or resetting Is_Valid if not.

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

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

   -- Base_Name --

   -- Base_Name --

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

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

   function Base_Name (Name : String) return String is

   function Base_Name (Name : String) return String is

      Simple : constant String := Simple_Name (Name);

      Simple : constant String := Simple_Name (Name);

      --  Simple'First is guaranteed to be 1

      --  Simple'First is guaranteed to be 1

   begin

   begin

      --  Look for the last dot in the file name and return the part of the

      --  Look for the last dot in the file name and return the part of the

      --  file name preceding this last dot. If the first dot is the first

      --  file name preceding this last dot. If the first dot is the first

      --  character of the file name, the base name is the empty string.

      --  character of the file name, the base name is the empty string.

      for Pos in reverse Simple'Range loop

      for Pos in reverse Simple'Range loop

         if Simple (Pos) = '.' then

         if Simple (Pos) = '.' then

            return Simple (1 .. Pos - 1);

            return Simple (1 .. Pos - 1);

         end if;

         end if;

      end loop;

      end loop;

      --  If there is no dot, return the complete file name

      --  If there is no dot, return the complete file name

      return Simple;

      return Simple;

   end Base_Name;

   end Base_Name;

   -----------

   -----------

   -- Close --

   -- Close --

   -----------

   -----------

   procedure Close (Dir : Dir_Type_Value) is

   procedure Close (Dir : Dir_Type_Value) is

      Discard : Integer;

      Discard : Integer;

      pragma Warnings (Off, Discard);

      pragma Warnings (Off, Discard);

      function closedir (directory : DIRs) return Integer;

      function closedir (directory : DIRs) return Integer;

      pragma Import (C, closedir, "__gnat_closedir");

      pragma Import (C, closedir, "__gnat_closedir");

   begin

   begin

      Discard := closedir (DIRs (Dir));

      Discard := closedir (DIRs (Dir));

   end Close;

   end Close;

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

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

   -- Compose --

   -- Compose --

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

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

   function Compose

   function Compose

     (Containing_Directory : String := "";

     (Containing_Directory : String := "";

      Name                 : String;

      Name                 : String;

      Extension            : String := "") return String

      Extension            : String := "") return String

   is

   is

      Result : String (1 .. Containing_Directory'Length +

      Result : String (1 .. Containing_Directory'Length +

                              Name'Length + Extension'Length + 2);

                              Name'Length + Extension'Length + 2);

      Last   : Natural;

      Last   : Natural;

   begin

   begin

      --  First, deal with the invalid cases

      --  First, deal with the invalid cases

      if Containing_Directory /= ""

      if Containing_Directory /= ""

        and then not Is_Valid_Path_Name (Containing_Directory)

        and then not Is_Valid_Path_Name (Containing_Directory)

      then

      then

         raise Name_Error with

         raise Name_Error with

           "invalid directory path name """ & Containing_Directory & '"';

           "invalid directory path name """ & Containing_Directory & '"';

      elsif

      elsif

        Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))

        Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))

      then

      then

         raise Name_Error with

         raise Name_Error with

           "invalid simple name """ & Name & '"';

           "invalid simple name """ & Name & '"';

      elsif Extension'Length /= 0

      elsif Extension'Length /= 0

        and then not Is_Valid_Simple_Name (Name & '.' & Extension)

        and then not Is_Valid_Simple_Name (Name & '.' & Extension)

      then

      then

         raise Name_Error with

         raise Name_Error with

           "invalid file name """ & Name & '.' & Extension & '"';

           "invalid file name """ & Name & '.' & Extension & '"';

      --  This is not an invalid case so build the path name

      --  This is not an invalid case so build the path name

      else

      else

         Last := Containing_Directory'Length;

         Last := Containing_Directory'Length;

         Result (1 .. Last) := Containing_Directory;

         Result (1 .. Last) := Containing_Directory;

         --  Add a directory separator if needed

         --  Add a directory separator if needed

         if Last /= 0 and then Result (Last) /= Dir_Separator then

         if Last /= 0 and then Result (Last) /= Dir_Separator then

            Last := Last + 1;

            Last := Last + 1;

            Result (Last) := Dir_Separator;

            Result (Last) := Dir_Separator;

         end if;

         end if;

         --  Add the file name

         --  Add the file name

         Result (Last + 1 .. Last + Name'Length) := Name;

         Result (Last + 1 .. Last + Name'Length) := Name;

         Last := Last + Name'Length;

         Last := Last + Name'Length;

         --  If extension was specified, add dot followed by this extension

         --  If extension was specified, add dot followed by this extension

         if Extension'Length /= 0 then

         if Extension'Length /= 0 then

            Last := Last + 1;

            Last := Last + 1;

            Result (Last) := '.';

            Result (Last) := '.';

            Result (Last + 1 .. Last + Extension'Length) := Extension;

            Result (Last + 1 .. Last + Extension'Length) := Extension;

            Last := Last + Extension'Length;

            Last := Last + Extension'Length;

         end if;

         end if;

         return Result (1 .. Last);

         return Result (1 .. Last);

      end if;

      end if;

   end Compose;

   end Compose;

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

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

   -- Containing_Directory --

   -- Containing_Directory --

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

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

   function Containing_Directory (Name : String) return String is

   function Containing_Directory (Name : String) return String is

   begin

   begin

      --  First, the invalid case

      --  First, the invalid case

      if not Is_Valid_Path_Name (Name) then

      if not Is_Valid_Path_Name (Name) then

         raise Name_Error with "invalid path name """ & Name & '"';

         raise Name_Error with "invalid path name """ & Name & '"';

      else

      else

         declare

         declare

            --  We need to resolve links because of A.16(47), since we must not

            --  We need to resolve links because of A.16(47), since we must not

            --  return alternative names for files.

            --  return alternative names for files.

            Norm    : constant String := Normalize_Pathname (Name);

            Norm    : constant String := Normalize_Pathname (Name);

            Last_DS : constant Natural :=

            Last_DS : constant Natural :=

                        Strings.Fixed.Index

                        Strings.Fixed.Index

                          (Name, Dir_Seps, Going => Strings.Backward);

                          (Name, Dir_Seps, Going => Strings.Backward);

         begin

         begin

            if Last_DS = 0 then

            if Last_DS = 0 then

               --  There is no directory separator, returns current working

               --  There is no directory separator, returns current working

               --  directory.

               --  directory.

               return Current_Directory;

               return Current_Directory;

            --  If Name indicates a root directory, raise Use_Error, because

            --  If Name indicates a root directory, raise Use_Error, because

            --  it has no containing directory.

            --  it has no containing directory.

            elsif Norm = "/"

            elsif Norm = "/"

              or else

              or else

                (Windows

                (Windows

                 and then

                 and then

                   (Norm = "\"

                   (Norm = "\"

                    or else

                    or else

                      (Norm'Length = 3

                      (Norm'Length = 3

                        and then Norm (Norm'Last - 1 .. Norm'Last) = ":\"

                        and then Norm (Norm'Last - 1 .. Norm'Last) = ":\"

                        and then (Norm (Norm'First) in 'a' .. 'z'

                        and then (Norm (Norm'First) in 'a' .. 'z'

                                   or else Norm (Norm'First) in 'A' .. 'Z'))))

                                   or else Norm (Norm'First) in 'A' .. 'Z'))))

            then

            then

               raise Use_Error with

               raise Use_Error with

                 "directory """ & Name & """ has no containing directory";

                 "directory """ & Name & """ has no containing directory";

            else

            else

               declare

               declare

                  Last   : Positive := Last_DS - Name'First + 1;

                  Last   : Positive := Last_DS - Name'First + 1;

                  Result : String (1 .. Last);

                  Result : String (1 .. Last);

               begin

               begin

                  Result := Name (Name'First .. Last_DS);

                  Result := Name (Name'First .. Last_DS);

                  --  Remove any trailing directory separator, except as the

                  --  Remove any trailing directory separator, except as the

                  --  first character or the first character following a drive

                  --  first character or the first character following a drive

                  --  number on Windows.

                  --  number on Windows.

                  while Last > 1 loop

                  while Last > 1 loop

                     exit when

                     exit when

                       Result (Last) /= '/'

                       Result (Last) /= '/'

                         and then

                         and then

                       Result (Last) /= Directory_Separator;

                       Result (Last) /= Directory_Separator;

                     exit when Windows

                     exit when Windows

                       and then Last = 3

                       and then Last = 3

                       and then Result (2) = ':'

                       and then Result (2) = ':'

                       and then

                       and then

                         (Result (1) in 'A' .. 'Z'

                         (Result (1) in 'A' .. 'Z'

                           or else

                           or else

                          Result (1) in 'a' .. 'z');

                          Result (1) in 'a' .. 'z');

                     Last := Last - 1;

                     Last := Last - 1;

                  end loop;

                  end loop;

                  --  Special case of current directory, identified by "."

                  --  Special case of current directory, identified by "."

                  if Last = 1 and then Result (1) = '.' then

                  if Last = 1 and then Result (1) = '.' then

                     return Current_Directory;

                     return Current_Directory;

                  --  Special case of "..": the current directory may be a root

                  --  Special case of "..": the current directory may be a root

                  --  directory.

                  --  directory.

                  elsif Last = 2 and then Result (1 .. 2) = ".." then

                  elsif Last = 2 and then Result (1 .. 2) = ".." then

                     return Containing_Directory (Current_Directory);

                     return Containing_Directory (Current_Directory);

                  else

                  else

                     return Result (1 .. Last);

                     return Result (1 .. Last);

                  end if;

                  end if;

               end;

               end;

            end if;

            end if;

         end;

         end;

      end if;

      end if;

   end Containing_Directory;

   end Containing_Directory;

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

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

   -- Copy_File --

   -- Copy_File --

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

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

   procedure Copy_File

   procedure Copy_File

     (Source_Name : String;

     (Source_Name : String;

      Target_Name : String;

      Target_Name : String;

      Form        : String := "")

      Form        : String := "")

   is

   is

      pragma Unreferenced (Form);

      pragma Unreferenced (Form);

      Success : Boolean;

      Success : Boolean;

   begin

   begin

      --  First, the invalid cases

      --  First, the invalid cases

      if not Is_Valid_Path_Name (Source_Name) then

      if not Is_Valid_Path_Name (Source_Name) then

         raise Name_Error with

         raise Name_Error with

           "invalid source path name """ & Source_Name & '"';

           "invalid source path name """ & Source_Name & '"';

      elsif not Is_Valid_Path_Name (Target_Name) then

      elsif not Is_Valid_Path_Name (Target_Name) then

         raise Name_Error with

         raise Name_Error with

           "invalid target path name """ & Target_Name & '"';

           "invalid target path name """ & Target_Name & '"';

      elsif not Is_Regular_File (Source_Name) then

      elsif not Is_Regular_File (Source_Name) then

         raise Name_Error with '"' & Source_Name & """ is not a file";

         raise Name_Error with '"' & Source_Name & """ is not a file";

      elsif Is_Directory (Target_Name) then

      elsif Is_Directory (Target_Name) then

         raise Use_Error with "target """ & Target_Name & """ is a directory";

         raise Use_Error with "target """ & Target_Name & """ is a directory";

      else

      else

         --  The implementation uses System.OS_Lib.Copy_File, with parameters

         --  The implementation uses System.OS_Lib.Copy_File, with parameters

         --  suitable for all platforms.

         --  suitable for all platforms.

         Copy_File (Source_Name, Target_Name, Success, Overwrite, None);

         Copy_File (Source_Name, Target_Name, Success, Overwrite, None);

         if not Success then

         if not Success then

            raise Use_Error with "copy of """ & Source_Name & """ failed";

            raise Use_Error with "copy of """ & Source_Name & """ failed";

         end if;

         end if;

      end if;

      end if;

   end Copy_File;

   end Copy_File;

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

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

   -- Create_Directory --

   -- Create_Directory --

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

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

   procedure Create_Directory

   procedure Create_Directory

     (New_Directory : String;

     (New_Directory : String;

      Form          : String := "")

      Form          : String := "")

   is

   is

      pragma Unreferenced (Form);

      pragma Unreferenced (Form);

      C_Dir_Name : constant String := New_Directory & ASCII.NUL;

      C_Dir_Name : constant String := New_Directory & ASCII.NUL;

      function mkdir (Dir_Name : String) return Integer;

      function mkdir (Dir_Name : String) return Integer;

      pragma Import (C, mkdir, "__gnat_mkdir");

      pragma Import (C, mkdir, "__gnat_mkdir");

   begin

   begin

      --  First, the invalid case

      --  First, the invalid case

      if not Is_Valid_Path_Name (New_Directory) then

      if not Is_Valid_Path_Name (New_Directory) then

         raise Name_Error with

         raise Name_Error with

           "invalid new directory path name """ & New_Directory & '"';

           "invalid new directory path name """ & New_Directory & '"';

      else

      else

         if mkdir (C_Dir_Name) /= 0 then

         if mkdir (C_Dir_Name) /= 0 then

            raise Use_Error with

            raise Use_Error with

              "creation of new directory """ & New_Directory & """ failed";

              "creation of new directory """ & New_Directory & """ failed";

         end if;

         end if;

      end if;

      end if;

   end Create_Directory;

   end Create_Directory;

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

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

   -- Create_Path --

   -- Create_Path --

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

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

   procedure Create_Path

   procedure Create_Path

     (New_Directory : String;

     (New_Directory : String;

      Form          : String := "")

      Form          : String := "")

   is

   is

      pragma Unreferenced (Form);

      pragma Unreferenced (Form);

      New_Dir : String (1 .. New_Directory'Length + 1);

      New_Dir : String (1 .. New_Directory'Length + 1);

      Last    : Positive := 1;

      Last    : Positive := 1;

   begin

   begin

      --  First, the invalid case

      --  First, the invalid case

      if not Is_Valid_Path_Name (New_Directory) then

      if not Is_Valid_Path_Name (New_Directory) then

         raise Name_Error with

         raise Name_Error with

           "invalid new directory path name """ & New_Directory & '"';

           "invalid new directory path name """ & New_Directory & '"';

      else

      else

         --  Build New_Dir with a directory separator at the end, so that the

         --  Build New_Dir with a directory separator at the end, so that the

         --  complete path will be found in the loop below.

         --  complete path will be found in the loop below.

         New_Dir (1 .. New_Directory'Length) := New_Directory;

         New_Dir (1 .. New_Directory'Length) := New_Directory;

         New_Dir (New_Dir'Last) := Directory_Separator;

         New_Dir (New_Dir'Last) := Directory_Separator;

         --  Create, if necessary, each directory in the path

         --  Create, if necessary, each directory in the path

         for J in 2 .. New_Dir'Last loop

         for J in 2 .. New_Dir'Last loop

            --  Look for the end of an intermediate directory

            --  Look for the end of an intermediate directory

            if New_Dir (J) /= Dir_Separator and then

            if New_Dir (J) /= Dir_Separator and then

               New_Dir (J) /= '/'

               New_Dir (J) /= '/'

            then

            then

               Last := J;

               Last := J;

            --  We have found a new intermediate directory each time we find

            --  We have found a new intermediate directory each time we find

            --  a first directory separator.

            --  a first directory separator.

            elsif New_Dir (J - 1) /= Dir_Separator and then

            elsif New_Dir (J - 1) /= Dir_Separator and then

                  New_Dir (J - 1) /= '/'

                  New_Dir (J - 1) /= '/'

            then

            then

               --  No need to create the directory if it already exists

               --  No need to create the directory if it already exists

               if Is_Directory (New_Dir (1 .. Last)) then

               if Is_Directory (New_Dir (1 .. Last)) then

                  null;

                  null;

               --  It is an error if a file with such a name already exists

               --  It is an error if a file with such a name already exists

               elsif Is_Regular_File (New_Dir (1 .. Last)) then

               elsif Is_Regular_File (New_Dir (1 .. Last)) then

                  raise Use_Error with

                  raise Use_Error with

                    "file """ & New_Dir (1 .. Last) & """ already exists";

                    "file """ & New_Dir (1 .. Last) & """ already exists";

               else

               else

                  Create_Directory (New_Directory => New_Dir (1 .. Last));

                  Create_Directory (New_Directory => New_Dir (1 .. Last));

               end if;

               end if;

            end if;

            end if;

         end loop;

         end loop;

      end if;

      end if;

   end Create_Path;

   end Create_Path;

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

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

   -- Current_Directory --

   -- Current_Directory --

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

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

   function Current_Directory return String is

   function Current_Directory return String is

      Path_Len : Natural := Max_Path;

      Path_Len : Natural := Max_Path;

      Buffer   : String (1 .. 1 + Max_Path + 1);

      Buffer   : String (1 .. 1 + Max_Path + 1);

      procedure Local_Get_Current_Dir

      procedure Local_Get_Current_Dir

        (Dir    : System.Address;

        (Dir    : System.Address;

         Length : System.Address);

         Length : System.Address);

      pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");

      pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");

   begin

   begin

      Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);

      Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);

      declare

      declare

         --  We need to resolve links because of A.16(47), since we must not

         --  We need to resolve links because of A.16(47), since we must not

         --  return alternative names for files

         --  return alternative names for files

         Cur : constant String := Normalize_Pathname (Buffer (1 .. Path_Len));

         Cur : constant String := Normalize_Pathname (Buffer (1 .. Path_Len));

      begin

      begin

         if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then

         if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then

            return Cur (1 .. Cur'Last - 1);

            return Cur (1 .. Cur'Last - 1);

         else

         else

            return Cur;

            return Cur;

         end if;

         end if;

      end;

      end;

   end Current_Directory;

   end Current_Directory;

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

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

   -- Delete_Directory --

   -- Delete_Directory --

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

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

   procedure Delete_Directory (Directory : String) is

   procedure Delete_Directory (Directory : String) is

   begin

   begin

      --  First, the invalid cases

      --  First, the invalid cases

      if not Is_Valid_Path_Name (Directory) then

      if not Is_Valid_Path_Name (Directory) then

         raise Name_Error with

         raise Name_Error with

           "invalid directory path name """ & Directory & '"';

           "invalid directory path name """ & Directory & '"';

      elsif not Is_Directory (Directory) then

      elsif not Is_Directory (Directory) then

         raise Name_Error with '"' & Directory & """ not a directory";

         raise Name_Error with '"' & Directory & """ not a directory";

      else

      else

         declare

         declare

            C_Dir_Name : constant String := Directory & ASCII.NUL;

            C_Dir_Name : constant String := Directory & ASCII.NUL;

         begin

         begin

            if rmdir (C_Dir_Name) /= 0 then

            if rmdir (C_Dir_Name) /= 0 then

               raise Use_Error with

               raise Use_Error with

                 "deletion of directory """ & Directory & """ failed";

                 "deletion of directory """ & Directory & """ failed";

            end if;

            end if;

         end;

         end;

      end if;

      end if;

   end Delete_Directory;

   end Delete_Directory;

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

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

   -- Delete_File --

   -- Delete_File --

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

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

   procedure Delete_File (Name : String) is

   procedure Delete_File (Name : String) is

      Success : Boolean;

      Success : Boolean;

   begin

   begin

      --  First, the invalid cases

      --  First, the invalid cases

      if not Is_Valid_Path_Name (Name) then

      if not Is_Valid_Path_Name (Name) then

         raise Name_Error with "invalid path name """ & Name & '"';

         raise Name_Error with "invalid path name """ & Name & '"';

      elsif not Is_Regular_File (Name) then

      elsif not Is_Regular_File (Name) then

         raise Name_Error with "file """ & Name & """ does not exist";

         raise Name_Error with "file """ & Name & """ does not exist";

      else

      else

         --  The implementation uses System.OS_Lib.Delete_File

         --  The implementation uses System.OS_Lib.Delete_File

         Delete_File (Name, Success);

         Delete_File (Name, Success);

         if not Success then

         if not Success then

            raise Use_Error with "file """ & Name & """ could not be deleted";

            raise Use_Error with "file """ & Name & """ could not be deleted";

         end if;

         end if;

      end if;

      end if;

   end Delete_File;

   end Delete_File;

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

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

   -- Delete_Tree --

   -- Delete_Tree --

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

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

   procedure Delete_Tree (Directory : String) is

   procedure Delete_Tree (Directory : String) is

      Current_Dir : constant String := Current_Directory;

      Current_Dir : constant String := Current_Directory;

      Search      : Search_Type;

      Search      : Search_Type;

      Dir_Ent     : Directory_Entry_Type;

      Dir_Ent     : Directory_Entry_Type;

   begin

   begin

      --  First, the invalid cases

      --  First, the invalid cases

      if not Is_Valid_Path_Name (Directory) then

      if not Is_Valid_Path_Name (Directory) then

         raise Name_Error with

         raise Name_Error with

           "invalid directory path name """ & Directory & '"';

           "invalid directory path name """ & Directory & '"';

      elsif not Is_Directory (Directory) then

      elsif not Is_Directory (Directory) then

         raise Name_Error with '"' & Directory & """ not a directory";

         raise Name_Error with '"' & Directory & """ not a directory";

      else

      else

         Set_Directory (Directory);

         Set_Directory (Directory);

         Start_Search (Search, Directory => ".", Pattern => "");

         Start_Search (Search, Directory => ".", Pattern => "");

         while More_Entries (Search) loop

         while More_Entries (Search) loop

            Get_Next_Entry (Search, Dir_Ent);

            Get_Next_Entry (Search, Dir_Ent);

            declare

            declare

               File_Name : constant String := Simple_Name (Dir_Ent);

               File_Name : constant String := Simple_Name (Dir_Ent);

            begin

            begin

               if System.OS_Lib.Is_Directory (File_Name) then

               if System.OS_Lib.Is_Directory (File_Name) then

                  if File_Name /= "." and then File_Name /= ".." then

                  if File_Name /= "." and then File_Name /= ".." then

                     Delete_Tree (File_Name);

                     Delete_Tree (File_Name);

                  end if;

                  end if;

               else

               else

                  Delete_File (File_Name);

                  Delete_File (File_Name);

               end if;

               end if;

            end;

            end;

         end loop;

         end loop;

         Set_Directory (Current_Dir);

         Set_Directory (Current_Dir);

         End_Search (Search);

         End_Search (Search);

         declare

         declare

            C_Dir_Name : constant String := Directory & ASCII.NUL;

            C_Dir_Name : constant String := Directory & ASCII.NUL;

         begin

         begin

            if rmdir (C_Dir_Name) /= 0 then

            if rmdir (C_Dir_Name) /= 0 then

               raise Use_Error with

               raise Use_Error with

                 "directory tree rooted at """ &

                 "directory tree rooted at """ &

                   Directory & """ could not be deleted";

                   Directory & """ could not be deleted";

            end if;

            end if;

         end;

         end;

      end if;

      end if;

   end Delete_Tree;

   end Delete_Tree;

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

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

   -- Exists --

   -- Exists --

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

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

   function Exists (Name : String) return Boolean is

   function Exists (Name : String) return Boolean is

   begin

   begin

      --  First, the invalid case

      --  First, the invalid case

      if not Is_Valid_Path_Name (Name) then

      if not Is_Valid_Path_Name (Name) then

         raise Name_Error with "invalid path name """ & Name & '"';

         raise Name_Error with "invalid path name """ & Name & '"';

      else

      else

         --  The implementation is in File_Exists

         --  The implementation is in File_Exists

         return File_Exists (Name);

         return File_Exists (Name);

      end if;

      end if;

   end Exists;

   end Exists;

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

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

   -- Extension --

   -- Extension --

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

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

   function Extension (Name : String) return String is

   function Extension (Name : String) return String is

   begin

   begin

      --  First, the invalid case

      --  First, the invalid case

      if not Is_Valid_Path_Name (Name) then

      if not Is_Valid_Path_Name (Name) then

         raise Name_Error with "invalid path name """ & Name & '"';

         raise Name_Error with "invalid path name """ & Name & '"';

      else

      else

         --  Look for first dot that is not followed by a directory separator

         --  Look for first dot that is not followed by a directory separator

         for Pos in reverse Name'Range loop

         for Pos in reverse Name'Range loop

            --  If a directory separator is found before a dot, there is no

            --  If a directory separator is found before a dot, there is no

            --  extension.

            --  extension.

            if Name (Pos) = Dir_Separator then

            if Name (Pos) = Dir_Separator then

               return Empty_String;

               return Empty_String;

            elsif Name (Pos) = '.' then

            elsif Name (Pos) = '.' then

               --  We found a dot, build the return value with lower bound 1

               --  We found a dot, build the return value with lower bound 1

               declare

               declare

                  subtype Result_Type is String (1 .. Name'Last - Pos);

                  subtype Result_Type is String (1 .. Name'Last - Pos);

               begin

               begin

                  return Result_Type (Name (Pos + 1 .. Name'Last));

                  return Result_Type (Name (Pos + 1 .. Name'Last));

               end;

               end;

            end if;

            end if;

         end loop;

         end loop;

         --  No dot were found, there is no extension

         --  No dot were found, there is no extension

         return Empty_String;

         return Empty_String;

      end if;

      end if;

   end Extension;

   end Extension;

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

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

   -- Fetch_Next_Entry --

   -- Fetch_Next_Entry --

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

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

   procedure Fetch_Next_Entry (Search : Search_Type) is

   procedure Fetch_Next_Entry (Search : Search_Type) is

      Name : String (1 .. 255);

      Name : String (1 .. 255);

      Last : Natural;

      Last : Natural;

      Kind : File_Kind := Ordinary_File;

      Kind : File_Kind := Ordinary_File;

      --  Initialized to avoid a compilation warning

      --  Initialized to avoid a compilation warning

      Filename_Addr : System.Address;

      Filename_Addr : System.Address;

      Filename_Len  : aliased Integer;

      Filename_Len  : aliased Integer;

      Buffer : array (0 .. Filename_Max + 12) of Character;

      Buffer : array (0 .. Filename_Max + 12) of Character;

      --  12 is the size of the dirent structure (see dirent.h), without the

      --  12 is the size of the dirent structure (see dirent.h), without the

      --  field for the filename.

      --  field for the filename.

      function readdir_gnat

      function readdir_gnat

        (Directory : System.Address;

        (Directory : System.Address;

         Buffer    : System.Address;

         Buffer    : System.Address;

         Last      : not null access Integer) return System.Address;

         Last      : not null access Integer) return System.Address;

      pragma Import (C, readdir_gnat, "__gnat_readdir");

      pragma Import (C, readdir_gnat, "__gnat_readdir");

      use System;

      use System;

   begin

   begin

      --  Search.Value.Is_Valid is always True when Fetch_Next_Entry is called

      --  Search.Value.Is_Valid is always True when Fetch_Next_Entry is called

      loop

      loop

         Filename_Addr :=

         Filename_Addr :=

           readdir_gnat

           readdir_gnat

             (System.Address (Search.Value.Dir),

             (System.Address (Search.Value.Dir),

              Buffer'Address,

              Buffer'Address,

              Filename_Len'Access);

              Filename_Len'Access);

         --  If no matching entry is found, set Is_Valid to False

         --  If no matching entry is found, set Is_Valid to False

         if Filename_Addr = System.Null_Address then

         if Filename_Addr = System.Null_Address then

            Search.Value.Is_Valid := False;

            Search.Value.Is_Valid := False;

            exit;

            exit;

         end if;

         end if;

         declare

         declare

            subtype Path_String is String (1 .. Filename_Len);

            subtype Path_String is String (1 .. Filename_Len);

            type    Path_String_Access is access Path_String;

            type    Path_String_Access is access Path_String;

            function Address_To_Access is new

            function Address_To_Access is new

              Ada.Unchecked_Conversion

              Ada.Unchecked_Conversion

                (Source => Address,

                (Source => Address,

                 Target => Path_String_Access);

                 Target => Path_String_Access);

            Path_Access : constant Path_String_Access :=

            Path_Access : constant Path_String_Access :=

                            Address_To_Access (Filename_Addr);

                            Address_To_Access (Filename_Addr);

         begin

         begin

            Last := Filename_Len;

            Last := Filename_Len;

            Name (1 .. Last) := Path_Access.all;

            Name (1 .. Last) := Path_Access.all;

         end;

         end;

         --  Check if the entry matches the pattern

         --  Check if the entry matches the pattern

         if Match (Name (1 .. Last), Search.Value.Pattern) then

         if Match (Name (1 .. Last), Search.Value.Pattern) then

            declare

            declare

               Full_Name : constant String :=

               Full_Name : constant String :=

                             Compose

                             Compose

                               (To_String

                               (To_String

                                  (Search.Value.Name), Name (1 .. Last));

                                  (Search.Value.Name), Name (1 .. Last));

               Found     : Boolean := False;

               Found     : Boolean := False;

            begin

            begin

               if File_Exists (Full_Name) then

               if File_Exists (Full_Name) then

                  --  Now check if the file kind matches the filter

                  --  Now check if the file kind matches the filter

                  if Is_Regular_File (Full_Name) then

                  if Is_Regular_File (Full_Name) then

                     if Search.Value.Filter (Ordinary_File) then

                     if Search.Value.Filter (Ordinary_File) then

                        Kind := Ordinary_File;

                        Kind := Ordinary_File;

                        Found := True;

                        Found := True;

                     end if;

                     end if;

                  elsif Is_Directory (Full_Name) then

                  elsif Is_Directory (Full_Name) then

                     if Search.Value.Filter (Directory) then

                     if Search.Value.Filter (Directory) then

                        Kind := Directory;

                        Kind := Directory;

                        Found := True;

                        Found := True;

                     end if;

                     end if;

                  elsif Search.Value.Filter (Special_File) then

                  elsif Search.Value.Filter (Special_File) then

                     Kind := Special_File;

                     Kind := Special_File;

                     Found := True;

                     Found := True;

                  end if;

                  end if;

                  --  If it does, update Search and return

                  --  If it does, update Search and return

                  if Found then

                  if Found then

                     Search.Value.Entry_Fetched := True;

                     Search.Value.Entry_Fetched := True;

                     Search.Value.Dir_Entry :=

                     Search.Value.Dir_Entry :=

                       (Is_Valid => True,

                       (Is_Valid => True,

                        Simple   => To_Unbounded_String (Name (1 .. Last)),

                        Simple   => To_Unbounded_String (Name (1 .. Last)),

                        Full     => To_Unbounded_String (Full_Name),

                        Full     => To_Unbounded_String (Full_Name),

                        Kind     => Kind);

                        Kind     => Kind);

                     exit;

                     exit;

                  end if;

                  end if;

               end if;

               end if;

            end;

            end;

         end if;

         end if;

      end loop;

      end loop;

   end Fetch_Next_Entry;

   end Fetch_Next_Entry;

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

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

   -- File_Exists --

   -- File_Exists --

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

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

   function File_Exists (Name : String) return Boolean is

   function File_Exists (Name : String) return Boolean is

      function C_File_Exists (A : System.Address) return Integer;

      function C_File_Exists (A : System.Address) return Integer;

      pragma Import (C, C_File_Exists, "__gnat_file_exists");

      pragma Import (C, C_File_Exists, "__gnat_file_exists");

      C_Name : String (1 .. Name'Length + 1);

      C_Name : String (1 .. Name'Length + 1);

   begin

   begin

      C_Name (1 .. Name'Length) := Name;

      C_Name (1 .. Name'Length) := Name;

      C_Name (C_Name'Last) := ASCII.NUL;

      C_Name (C_Name'Last) := ASCII.NUL;

      return C_File_Exists (C_Name (1)'Address) = 1;

      return C_File_Exists (C_Name (1)'Address) = 1;

   end File_Exists;

   end File_Exists;

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

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

   -- Finalize --

   -- Finalize --

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

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

   procedure Finalize (Search : in out Search_Type) is

   procedure Finalize (Search : in out Search_Type) is

   begin

   begin

      if Search.Value /= null then

      if Search.Value /= null then

         --  Close the directory, if one is open

         --  Close the directory, if one is open

         if Search.Value.Dir /= No_Dir then

         if Search.Value.Dir /= No_Dir then

            Close (Search.Value.Dir);

            Close (Search.Value.Dir);

         end if;

         end if;

         Free (Search.Value);

         Free (Search.Value);

      end if;

      end if;

   end Finalize;

   end Finalize;

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

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

   -- Full_Name --

   -- Full_Name --

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

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

   function Full_Name (Name : String) return String is

   function Full_Name (Name : String) return String is

   begin

   begin

      --  First, the invalid case

      --  First, the invalid case

      if not Is_Valid_Path_Name (Name) then