[thirdparty/gcc.git] / gcc / ada / g-dirope.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--            G N A T . D I R E C T O R Y _ O P E R A T I O N S             --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1998-2003 Ada Core Technologies, Inc.           --
--                                                                          --
-- 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- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;
with Unchecked_Deallocation;
with Unchecked_Conversion;
with System;  use System;

with GNAT.OS_Lib;

package body GNAT.Directory_Operations is

   use Ada;

   type Dir_Type_Value is new System.Address;
   --  This is the low-level address directory structure as returned by the C
   --  opendir routine.

   Filename_Max : constant Integer := 1024;
   --  1024 is the value of FILENAME_MAX in stdio.h

   procedure Free is new
     Unchecked_Deallocation (Dir_Type_Value, Dir_Type);

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

   function Base_Name
     (Path   : Path_Name;
      Suffix : String    := "")
      return   String
   is
      function Get_File_Names_Case_Sensitive return Integer;
      pragma Import
        (C, Get_File_Names_Case_Sensitive,
         "__gnat_get_file_names_case_sensitive");

      Case_Sensitive_File_Name : constant Boolean :=
                                   Get_File_Names_Case_Sensitive = 1;

      function Basename
        (Path   : Path_Name;
         Suffix : String    := "")
         return String;
      --  This function does the job. The only difference between Basename
      --  and Base_Name (the parent function) is that the former is case
      --  sensitive, while the latter is not. Path and Suffix are adjusted
      --  appropriately before calling Basename under platforms where the
      --  file system is not case sensitive.

      --------------
      -- Basename --
      --------------

      function Basename
        (Path   : Path_Name;
         Suffix : String    := "")
         return   String
      is
         Cut_Start : Natural :=
                       Strings.Fixed.Index
                         (Path, Dir_Seps, Going => Strings.Backward);
         Cut_End : Natural;

      begin
         --  Cut_Start point to the first basename character

         if Cut_Start = 0 then
            Cut_Start := Path'First;

         else
            Cut_Start := Cut_Start + 1;
         end if;

         --  Cut_End point to the last basename character.

         Cut_End := Path'Last;

         --  If basename ends with Suffix, adjust Cut_End.

         if Suffix /= ""
           and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
         then
            Cut_End := Path'Last - Suffix'Length;
         end if;

         Check_For_Standard_Dirs : declare
            Offset : constant Integer := Path'First - Base_Name.Path'First;
            BN     : constant String  :=
                       Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
            --  Here we use Base_Name.Path to keep the original casing

         begin
            if BN = "." or else BN = ".." then
               return "";

            elsif BN'Length > 2
              and then Characters.Handling.Is_Letter (BN (BN'First))
              and then BN (BN'First + 1) = ':'
            then
               --  We have a DOS drive letter prefix, remove it

               return BN (BN'First + 2 .. BN'Last);

            else
               return BN;
            end if;
         end Check_For_Standard_Dirs;
      end Basename;

   --  Start processing for Base_Name

   begin
      if Path'Length <= Suffix'Length then
         return Path;
      end if;

      if Case_Sensitive_File_Name then
         return Basename (Path, Suffix);
      else
         return Basename
           (Characters.Handling.To_Lower (Path),
            Characters.Handling.To_Lower (Suffix));
      end if;
   end Base_Name;

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

   procedure Change_Dir (Dir_Name : Dir_Name_Str) is
      C_Dir_Name : constant String := Dir_Name & ASCII.NUL;

      function chdir (Dir_Name : String) return Integer;
      pragma Import (C, chdir, "chdir");

   begin
      if chdir (C_Dir_Name) /= 0 then
         raise Directory_Error;
      end if;
   end Change_Dir;

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

   procedure Close (Dir : in out Dir_Type) is

      function closedir (Directory : System.Address) return Integer;
      pragma Import (C, closedir, "closedir");

      Discard : Integer;
      pragma Warnings (Off, Discard);

   begin
      if not Is_Open (Dir) then
         raise Directory_Error;
      end if;

      Discard := closedir (System.Address (Dir.all));
      Free (Dir);
   end Close;

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

   function Dir_Name (Path : Path_Name) return Dir_Name_Str is
      Last_DS : constant Natural :=
                  Strings.Fixed.Index
                    (Path, Dir_Seps, Going => Strings.Backward);

   begin
      if Last_DS = 0 then

         --  There is no directory separator, returns current working directory

         return "." & Dir_Separator;

      else
         return Path (Path'First .. Last_DS);
      end if;
   end Dir_Name;

   -----------------
   -- Expand_Path --
   -----------------

   function Expand_Path
     (Path : Path_Name;
      Mode : Environment_Style := System_Default)
      return Path_Name
   is
      Environment_Variable_Char : Character;
      pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");

      Result      : OS_Lib.String_Access := new String (1 .. 200);
      Result_Last : Natural := 0;

      procedure Append (C : Character);
      procedure Append (S : String);
      --  Append to Result

      procedure Double_Result_Size;
      --  Reallocate Result, doubling its size

      function Is_Var_Prefix (C : Character) return Boolean;
      pragma Inline (Is_Var_Prefix);

      procedure Read (K : in out Positive);
      --  Update Result while reading current Path starting at position K. If
      --  a variable is found, call Var below.

      procedure Var (K : in out Positive);
      --  Translate variable name starting at position K with the associated
      --  environment value.

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

      procedure Append (C : Character) is
      begin
         if Result_Last = Result'Last then
            Double_Result_Size;
         end if;

         Result_Last := Result_Last + 1;
         Result (Result_Last) := C;
      end Append;

      procedure Append (S : String) is
      begin
         while Result_Last + S'Length - 1 > Result'Last loop
            Double_Result_Size;
         end loop;

         Result (Result_Last + 1 .. Result_Last + S'Length) := S;
         Result_Last := Result_Last + S'Length;
      end Append;

      ------------------------
      -- Double_Result_Size --
      ------------------------

      procedure Double_Result_Size is
         New_Result : constant OS_Lib.String_Access :=
           new String (1 .. 2 * Result'Last);

      begin
         New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
         OS_Lib.Free (Result);
         Result := New_Result;
      end Double_Result_Size;

      -------------------
      -- Is_Var_Prefix --
      -------------------

      function Is_Var_Prefix (C : Character) return Boolean is
      begin
         return (C = Environment_Variable_Char and then Mode = System_Default)
           or else
             (C = '$' and then (Mode = UNIX or else Mode = Both))
           or else
             (C = '%' and then (Mode = DOS or else Mode = Both));
      end Is_Var_Prefix;

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

      procedure Read (K : in out Positive) is
         P : Character;
      begin
         For_All_Characters : loop
            if Is_Var_Prefix (Path (K)) then
               P := Path (K);

               --  Could be a variable

               if K < Path'Last then

                  if Path (K + 1) = P then

                     --  Not a variable after all, this is a double $ or %,
                     --  just insert one in the result string.

                     Append (P);
                     K := K + 1;

                  else
                     --  Let's parse the variable

                     Var (K);
                  end if;

               else
                  --  We have an ending $ or % sign

                  Append (P);
               end if;

            else
               --  This is a standard character, just add it to the result

               Append (Path (K));
            end if;

            --  Skip to next character

            K := K + 1;

            exit For_All_Characters when K > Path'Last;
         end loop For_All_Characters;
      end Read;

      ---------
      -- Var --
      ---------

      procedure Var (K : in out Positive) is
         P : constant Character := Path (K);
         T : Character;
         E : Positive;

      begin
         K := K + 1;

         if P = '%' or else Path (K) = '{' then

            --  Set terminator character

            if P = '%' then
               T := '%';
            else
               T := '}';
               K := K + 1;
            end if;

            --  Look for terminator character, k point to the first character
            --  for the variable name.

            E := K;

            loop
               E := E + 1;
               exit when Path (E) = T or else E = Path'Last;
            end loop;

            if Path (E) = T then

               --  OK found, translate with environment value

               declare
                  Env : OS_Lib.String_Access :=
                          OS_Lib.Getenv (Path (K .. E - 1));

               begin
                  Append (Env.all);
                  OS_Lib.Free (Env);
               end;

            else
               --  No terminator character, not a variable after all or a
               --  syntax error, ignore it, insert string as-is.

               Append (P);       --  Add prefix character

               if T = '}' then   --  If we were looking for curly bracket
                  Append ('{');  --  terminator, add the curly bracket
               end if;

               Append (Path (K .. E));
            end if;

         else
            --  The variable name is everything from current position to first
            --  non letter/digit character.

            E := K;

            --  Check that first chartacter is a letter

            if Characters.Handling.Is_Letter (Path (E)) then
               E := E + 1;

               Var_Name : loop
                  exit Var_Name when E > Path'Last;

                  if Characters.Handling.Is_Letter (Path (E))
                    or else Characters.Handling.Is_Digit (Path (E))
                  then
                     E := E + 1;
                  else
                     exit Var_Name;
                  end if;
               end loop Var_Name;

               E := E - 1;

               declare
                  Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));

               begin
                  Append (Env.all);
                  OS_Lib.Free (Env);
               end;

            else
               --  This is not a variable after all

               Append ('$');
               Append (Path (E));
            end if;

         end if;

         K := E;
      end Var;

   --  Start of processing for Expand_Path

   begin
      declare
         K : Positive := Path'First;

      begin
         Read (K);

         declare
            Returned_Value : constant String := Result (1 .. Result_Last);

         begin
            OS_Lib.Free (Result);
            return Returned_Value;
         end;
      end;
   end Expand_Path;

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

   function File_Extension (Path : Path_Name) return String is
      First : Natural :=
                Strings.Fixed.Index
                  (Path, Dir_Seps, Going => Strings.Backward);

      Dot : Natural;

   begin
      if First = 0 then
         First := Path'First;
      end if;

      Dot := Strings.Fixed.Index (Path (First .. Path'Last),
                                  ".",
                                  Going => Strings.Backward);

      if Dot = 0 or else Dot = Path'Last then
         return "";
      else
         return Path (Dot .. Path'Last);
      end if;
   end File_Extension;

   ---------------
   -- File_Name --
   ---------------

   function File_Name (Path : Path_Name) return String is
   begin
      return Base_Name (Path);
   end File_Name;

   ---------------------
   -- Format_Pathname --
   ---------------------

   function Format_Pathname
     (Path  : Path_Name;
      Style : Path_Style := System_Default)
      return  String
   is
      N_Path       : String   := Path;
      K            : Positive := N_Path'First;
      Prev_Dirsep  : Boolean  := False;

   begin
      if Dir_Separator = '\'
        and then Path'Length > 1
        and then Path (K .. K + 1) = "\\"
      then
         if Style = UNIX then
            N_Path (K .. K + 1) := "//";
         end if;

         K := K + 2;
      end if;

      for J in K .. Path'Last loop
         if Strings.Maps.Is_In (Path (J), Dir_Seps) then
            if not Prev_Dirsep then
               case Style is
                  when UNIX           => N_Path (K) := '/';
                  when DOS            => N_Path (K) := '\';
                  when System_Default => N_Path (K) := Dir_Separator;
               end case;

               K := K + 1;
            end if;

            Prev_Dirsep := True;

         else
            N_Path (K) := Path (J);
            K := K + 1;
            Prev_Dirsep := False;
         end if;
      end loop;

      return N_Path (N_Path'First .. K - 1);
   end Format_Pathname;

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

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

   function Get_Current_Dir return Dir_Name_Str is
      Current_Dir : String (1 .. Max_Path + 1);
      Last        : Natural;

   begin
      Get_Current_Dir (Current_Dir, Last);
      return Current_Dir (1 .. Last);
   end Get_Current_Dir;

   procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
      Path_Len : Natural := Max_Path;
      Buffer   : String (Dir'First .. Dir'First + Max_Path + 1);

      procedure Local_Get_Current_Dir
        (Dir    : System.Address;
         Length : System.Address);
      pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");

   begin
      Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);

      if Dir'Length > Path_Len then
         Last := Dir'First + Path_Len - 1;
      else
         Last := Dir'Last;
      end if;

      Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
   end Get_Current_Dir;

   -------------
   -- Is_Open --
   -------------

   function Is_Open (Dir : Dir_Type) return Boolean is
   begin
      return Dir /= Null_Dir
        and then System.Address (Dir.all) /= System.Null_Address;
   end Is_Open;

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

   procedure Make_Dir (Dir_Name : Dir_Name_Str) is
      C_Dir_Name : constant String := Dir_Name & ASCII.NUL;

      function mkdir (Dir_Name : String) return Integer;
      pragma Import (C, mkdir, "__gnat_mkdir");

   begin
      if mkdir (C_Dir_Name) /= 0 then
         raise Directory_Error;
      end if;
   end Make_Dir;

   ----------
   -- Open --
   ----------

   procedure Open
     (Dir      : out Dir_Type;
      Dir_Name : Dir_Name_Str)
   is
      C_File_Name : constant String := Dir_Name & ASCII.NUL;

      function opendir
        (File_Name : String)
         return      Dir_Type_Value;
      pragma Import (C, opendir, "opendir");

   begin
      Dir := new Dir_Type_Value'(opendir (C_File_Name));

      if not Is_Open (Dir) then
         Free (Dir);
         Dir := Null_Dir;
         raise Directory_Error;
      end if;
   end Open;

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

   procedure Read
     (Dir  : in out Dir_Type;
      Str  : out String;
      Last : out Natural)
   is
      Filename_Addr : Address;
      Filename_Len  : Integer;

      Buffer : array (0 .. Filename_Max + 12) of Character;
      --  12 is the size of the dirent structure (see dirent.h), without the
      --  field for the filename.

      function readdir_gnat
        (Directory : System.Address;
         Buffer    : System.Address)
         return      System.Address;
      pragma Import (C, readdir_gnat, "__gnat_readdir");

      function strlen (S : Address) return Integer;
      pragma Import (C, strlen, "strlen");

   begin
      if not Is_Open (Dir) then
         raise Directory_Error;
      end if;

      Filename_Addr :=
        readdir_gnat (System.Address (Dir.all), Buffer'Address);

      if Filename_Addr = System.Null_Address then
         Last := 0;
         return;
      end if;

      Filename_Len  := strlen (Filename_Addr);

      if Str'Length > Filename_Len then
         Last := Str'First + Filename_Len - 1;
      else
         Last := Str'Last;
      end if;

      declare
         subtype Path_String is String (1 .. Filename_Len);
         type    Path_String_Access is access Path_String;

         function Address_To_Access is new
           Unchecked_Conversion
             (Source => Address,
              Target => Path_String_Access);

         Path_Access : constant Path_String_Access :=
                         Address_To_Access (Filename_Addr);

      begin
         for J in Str'First .. Last loop
            Str (J) := Path_Access (J - Str'First + 1);
         end loop;
      end;
   end Read;

   -------------------------
   -- Read_Is_Thread_Sage --
   -------------------------

   function Read_Is_Thread_Safe return Boolean is

      function readdir_is_thread_safe return Integer;
      pragma Import
        (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");

   begin
      return (readdir_is_thread_safe /= 0);
   end Read_Is_Thread_Safe;

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

   procedure Remove_Dir
     (Dir_Name  : Dir_Name_Str;
      Recursive : Boolean := False)
   is
      C_Dir_Name  : constant String := Dir_Name & ASCII.NUL;
      Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
      Last        : Integer;
      Str         : String (1 .. Filename_Max);
      Success     : Boolean;
      Working_Dir : Dir_Type;

      procedure rmdir (Dir_Name : String);
      pragma Import (C, rmdir, "rmdir");

   begin
      --  Remove the directory only if it is empty

      if not Recursive then
         rmdir (C_Dir_Name);

         if GNAT.OS_Lib.Is_Directory (Dir_Name) then
            raise Directory_Error;
         end if;

      --  Remove directory and all files and directories that it may contain

      else
         Change_Dir (Dir_Name);
         Open (Working_Dir, ".");

         loop
            Read (Working_Dir, Str, Last);
            exit when Last = 0;

            if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
               if Str (1 .. Last) /= "." and then Str (1 .. Last) /= ".." then
                  Remove_Dir (Str (1 .. Last), True);
                  Remove_Dir (Str (1 .. Last));
               end if;

            else
               GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);

               if not Success then
                  Change_Dir (Current_Dir);
                  raise Directory_Error;
               end if;
            end if;
         end loop;

         Change_Dir (Current_Dir);
         Close (Working_Dir);
         Remove_Dir (Dir_Name);
      end if;
   end Remove_Dir;

end GNAT.Directory_Operations;
Commit	Line	Data
38cbfe40 RK	1	------------------------------------------------------------------------------
	2	-- --
	3	-- GNAT COMPILER COMPONENTS --
	4	-- --
	5	-- G N A T . D I R E C T O R Y _ O P E R A T I O N S --
	6	-- --
	7	-- B o d y --
	8	-- --
fbf5a39b	9	-- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
38cbfe40 RK	10	-- --
	11	-- GNAT is free software; you can redistribute it and/or modify it under --
	12	-- terms of the GNU General Public License as published by the Free Soft- --
	13	-- ware Foundation; either version 2, or (at your option) any later ver- --
	14	-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
	15	-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
	16	-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
	17	-- for more details. You should have received a copy of the GNU General --
	18	-- Public License distributed with GNAT; see file COPYING. If not, write --
	19	-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
	20	-- MA 02111-1307, USA. --
	21	-- --
	22	-- As a special exception, if other files instantiate generics from this --
	23	-- unit, or you link this unit with other files to produce an executable, --
	24	-- this unit does not by itself cause the resulting executable to be --
	25	-- covered by the GNU General Public License. This exception does not --
	26	-- however invalidate any other reasons why the executable file might be --
	27	-- covered by the GNU Public License. --
	28	-- --
fbf5a39b AC	29	-- GNAT was originally developed by the GNAT team at New York University. --
fbf5a39b AC	30	-- Extensive contributions were provided by Ada Core Technologies Inc. --
38cbfe40 RK	31	-- --
	32	------------------------------------------------------------------------------
	33
	34	with Ada.Characters.Handling;
	35	with Ada.Strings.Fixed;
38cbfe40 RK	36	with Ada.Strings.Maps;
	37	with Unchecked_Deallocation;
	38	with Unchecked_Conversion;
	39	with System; use System;
	40
38cbfe40 RK	41	with GNAT.OS_Lib;
	42
	43	package body GNAT.Directory_Operations is
	44
	45	use Ada;
	46
	47	type Dir_Type_Value is new System.Address;
	48	-- This is the low-level address directory structure as returned by the C
	49	-- opendir routine.
	50
fbf5a39b AC	51	Filename_Max : constant Integer := 1024;
	52	-- 1024 is the value of FILENAME_MAX in stdio.h
	53
38cbfe40 RK	54	procedure Free is new
	55	Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
	56
	57	---------------
	58	-- Base_Name --
	59	---------------
	60
	61	function Base_Name
	62	(Path : Path_Name;
	63	Suffix : String := "")
	64	return String
	65	is
	66	function Get_File_Names_Case_Sensitive return Integer;
	67	pragma Import
	68	(C, Get_File_Names_Case_Sensitive,
	69	"__gnat_get_file_names_case_sensitive");
	70
	71	Case_Sensitive_File_Name : constant Boolean :=
	72	Get_File_Names_Case_Sensitive = 1;
	73
	74	function Basename
	75	(Path : Path_Name;
	76	Suffix : String := "")
	77	return String;
	78	-- This function does the job. The only difference between Basename
	79	-- and Base_Name (the parent function) is that the former is case
	80	-- sensitive, while the latter is not. Path and Suffix are adjusted
	81	-- appropriately before calling Basename under platforms where the
	82	-- file system is not case sensitive.
	83
	84	--------------
	85	-- Basename --
	86	--------------
	87
	88	function Basename
	89	(Path : Path_Name;
	90	Suffix : String := "")
	91	return String
	92	is
	93	Cut_Start : Natural :=
	94	Strings.Fixed.Index
	95	(Path, Dir_Seps, Going => Strings.Backward);
	96	Cut_End : Natural;
	97
	98	begin
	99	-- Cut_Start point to the first basename character
	100
	101	if Cut_Start = 0 then
	102	Cut_Start := Path'First;
	103
	104	else
	105	Cut_Start := Cut_Start + 1;
	106	end if;
	107
	108	-- Cut_End point to the last basename character.
	109
	110	Cut_End := Path'Last;
	111
	112	-- If basename ends with Suffix, adjust Cut_End.
	113
	114	if Suffix /= ""
	115	and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
	116	then
	117	Cut_End := Path'Last - Suffix'Length;
118	end if;
119
120	Check_For_Standard_Dirs : declare
5c1ba4cc PO	121	Offset : constant Integer := Path'First - Base_Name.Path'First;
	122	BN : constant String :=
	123	Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
	124	-- Here we use Base_Name.Path to keep the original casing
38cbfe40 RK	125
	126	begin
	127	if BN = "." or else BN = ".." then
	128	return "";
	129
	130	elsif BN'Length > 2
	131	and then Characters.Handling.Is_Letter (BN (BN'First))
	132	and then BN (BN'First + 1) = ':'
	133	then
	134	-- We have a DOS drive letter prefix, remove it
	135
	136	return BN (BN'First + 2 .. BN'Last);
	137
	138	else
	139	return BN;
	140	end if;
	141	end Check_For_Standard_Dirs;
	142	end Basename;
	143
	144	-- Start processing for Base_Name
	145
	146	begin
fbf5a39b AC	147	if Path'Length <= Suffix'Length then
	148	return Path;
	149	end if;
	150
38cbfe40 RK	151	if Case_Sensitive_File_Name then
38cbfe40 RK	152	return Basename (Path, Suffix);
38cbfe40 RK	153	else
	154	return Basename
	155	(Characters.Handling.To_Lower (Path),
	156	Characters.Handling.To_Lower (Suffix));
	157	end if;
	158	end Base_Name;
	159
	160	----------------
	161	-- Change_Dir --
	162	----------------
	163
	164	procedure Change_Dir (Dir_Name : Dir_Name_Str) is
fbf5a39b	165	C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
38cbfe40 RK	166
	167	function chdir (Dir_Name : String) return Integer;
	168	pragma Import (C, chdir, "chdir");
	169
	170	begin
	171	if chdir (C_Dir_Name) /= 0 then
	172	raise Directory_Error;
	173	end if;
	174	end Change_Dir;
	175
	176	-----------
	177	-- Close --
	178	-----------
	179
	180	procedure Close (Dir : in out Dir_Type) is
	181
	182	function closedir (Directory : System.Address) return Integer;
	183	pragma Import (C, closedir, "closedir");
	184
	185	Discard : Integer;
fbf5a39b	186	pragma Warnings (Off, Discard);
38cbfe40 RK	187
	188	begin
	189	if not Is_Open (Dir) then
	190	raise Directory_Error;
	191	end if;
	192
	193	Discard := closedir (System.Address (Dir.all));
	194	Free (Dir);
	195	end Close;
	196
	197	--------------
	198	-- Dir_Name --
	199	--------------
	200
	201	function Dir_Name (Path : Path_Name) return Dir_Name_Str is
	202	Last_DS : constant Natural :=
	203	Strings.Fixed.Index
	204	(Path, Dir_Seps, Going => Strings.Backward);
	205
	206	begin
	207	if Last_DS = 0 then
	208
	209	-- There is no directory separator, returns current working directory
	210
	211	return "." & Dir_Separator;
	212
	213	else
	214	return Path (Path'First .. Last_DS);
	215	end if;
	216	end Dir_Name;
	217
	218	-----------------
	219	-- Expand_Path --
	220	-----------------
	221
fbf5a39b AC	222	function Expand_Path
	223	(Path : Path_Name;
	224	Mode : Environment_Style := System_Default)
	225	return Path_Name
	226	is
	227	Environment_Variable_Char : Character;
	228	pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
0873bafc GB	229
	230	Result : OS_Lib.String_Access := new String (1 .. 200);
	231	Result_Last : Natural := 0;
	232
	233	procedure Append (C : Character);
	234	procedure Append (S : String);
	235	-- Append to Result
	236
	237	procedure Double_Result_Size;
	238	-- Reallocate Result, doubling its size
38cbfe40	239
fbf5a39b AC	240	function Is_Var_Prefix (C : Character) return Boolean;
	241	pragma Inline (Is_Var_Prefix);
	242
38cbfe40 RK	243	procedure Read (K : in out Positive);
	244	-- Update Result while reading current Path starting at position K. If
	245	-- a variable is found, call Var below.
	246
	247	procedure Var (K : in out Positive);
	248	-- Translate variable name starting at position K with the associated
638e383e	249	-- environment value.
38cbfe40	250
0873bafc GB	251	------------
	252	-- Append --
	253	------------
	254
	255	procedure Append (C : Character) is
	256	begin
	257	if Result_Last = Result'Last then
	258	Double_Result_Size;
	259	end if;
	260
	261	Result_Last := Result_Last + 1;
	262	Result (Result_Last) := C;
	263	end Append;
38cbfe40	264
0873bafc GB	265	procedure Append (S : String) is
	266	begin
	267	while Result_Last + S'Length - 1 > Result'Last loop
	268	Double_Result_Size;
	269	end loop;
	270
598c3446 GB	271	Result (Result_Last + 1 .. Result_Last + S'Length) := S;
598c3446 GB	272	Result_Last := Result_Last + S'Length;
0873bafc GB	273	end Append;
	274
	275	------------------------
	276	-- Double_Result_Size --
	277	------------------------
	278
	279	procedure Double_Result_Size is
	280	New_Result : constant OS_Lib.String_Access :=
	281	new String (1 .. 2 * Result'Last);
	282
	283	begin
	284	New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
	285	OS_Lib.Free (Result);
	286	Result := New_Result;
	287	end Double_Result_Size;
38cbfe40	288
fbf5a39b AC	289	-------------------
	290	-- Is_Var_Prefix --
	291	-------------------
	292
	293	function Is_Var_Prefix (C : Character) return Boolean is
	294	begin
	295	return (C = Environment_Variable_Char and then Mode = System_Default)
	296	or else
	297	(C = '$' and then (Mode = UNIX or else Mode = Both))
	298	or else
	299	(C = '%' and then (Mode = DOS or else Mode = Both));
	300	end Is_Var_Prefix;
	301
38cbfe40 RK	302	----------
	303	-- Read --
	304	----------
	305
	306	procedure Read (K : in out Positive) is
fbf5a39b	307	P : Character;
38cbfe40 RK	308	begin
38cbfe40 RK	309	For_All_Characters : loop
fbf5a39b AC	310	if Is_Var_Prefix (Path (K)) then
fbf5a39b AC	311	P := Path (K);
38cbfe40 RK	312
	313	-- Could be a variable
	314
	315	if K < Path'Last then
	316
fbf5a39b	317	if Path (K + 1) = P then
38cbfe40	318
fbf5a39b AC	319	-- Not a variable after all, this is a double $ or %,
fbf5a39b AC	320	-- just insert one in the result string.
38cbfe40	321
fbf5a39b	322	Append (P);
38cbfe40 RK	323	K := K + 1;
	324
	325	else
	326	-- Let's parse the variable
	327
38cbfe40 RK	328	Var (K);
	329	end if;
	330
	331	else
fbf5a39b	332	-- We have an ending $ or % sign
38cbfe40	333
fbf5a39b	334	Append (P);
38cbfe40 RK	335	end if;
	336
	337	else
	338	-- This is a standard character, just add it to the result
	339
0873bafc	340	Append (Path (K));
38cbfe40 RK	341	end if;
	342
	343	-- Skip to next character
	344
	345	K := K + 1;
	346
	347	exit For_All_Characters when K > Path'Last;
	348	end loop For_All_Characters;
	349	end Read;
	350
	351	---------
	352	-- Var --
	353	---------
	354
	355	procedure Var (K : in out Positive) is
fbf5a39b AC	356	P : constant Character := Path (K);
fbf5a39b AC	357	T : Character;
38cbfe40 RK	358	E : Positive;
	359
	360	begin
fbf5a39b AC	361	K := K + 1;
	362
	363	if P = '%' or else Path (K) = '{' then
38cbfe40	364
fbf5a39b AC	365	-- Set terminator character
	366
	367	if P = '%' then
	368	T := '%';
	369	else
	370	T := '}';
	371	K := K + 1;
	372	end if;
	373
	374	-- Look for terminator character, k point to the first character
	375	-- for the variable name.
38cbfe40 RK	376
	377	E := K;
	378
	379	loop
	380	E := E + 1;
fbf5a39b	381	exit when Path (E) = T or else E = Path'Last;
38cbfe40 RK	382	end loop;
38cbfe40 RK	383
fbf5a39b	384	if Path (E) = T then
38cbfe40	385
638e383e	386	-- OK found, translate with environment value
38cbfe40 RK	387
	388	declare
	389	Env : OS_Lib.String_Access :=
fbf5a39b	390	OS_Lib.Getenv (Path (K .. E - 1));
38cbfe40 RK	391
38cbfe40 RK	392	begin
0873bafc GB	393	Append (Env.all);
0873bafc GB	394	OS_Lib.Free (Env);
38cbfe40 RK	395	end;
	396
	397	else
fbf5a39b	398	-- No terminator character, not a variable after all or a
38cbfe40 RK	399	-- syntax error, ignore it, insert string as-is.
38cbfe40 RK	400
fbf5a39b AC	401	Append (P); -- Add prefix character
	402
	403	if T = '}' then -- If we were looking for curly bracket
	404	Append ('{'); -- terminator, add the curly bracket
	405	end if;
	406
0873bafc	407	Append (Path (K .. E));
38cbfe40 RK	408	end if;
	409
	410	else
	411	-- The variable name is everything from current position to first
	412	-- non letter/digit character.
	413
	414	E := K;
	415
	416	-- Check that first chartacter is a letter
	417
	418	if Characters.Handling.Is_Letter (Path (E)) then
	419	E := E + 1;
	420
	421	Var_Name : loop
de76a39c	422	exit Var_Name when E > Path'Last;
38cbfe40 RK	423
	424	if Characters.Handling.Is_Letter (Path (E))
	425	or else Characters.Handling.Is_Digit (Path (E))
	426	then
	427	E := E + 1;
	428	else
38cbfe40 RK	429	exit Var_Name;
	430	end if;
	431	end loop Var_Name;
	432
de76a39c GB	433	E := E - 1;
de76a39c GB	434
38cbfe40 RK	435	declare
	436	Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
	437
	438	begin
0873bafc GB	439	Append (Env.all);
0873bafc GB	440	OS_Lib.Free (Env);
38cbfe40 RK	441	end;
	442
	443	else
	444	-- This is not a variable after all
	445
0873bafc GB	446	Append ('$');
0873bafc GB	447	Append (Path (E));
38cbfe40 RK	448	end if;
	449
	450	end if;
	451
	452	K := E;
	453	end Var;
	454
	455	-- Start of processing for Expand_Path
	456
	457	begin
	458	declare
	459	K : Positive := Path'First;
	460
	461	begin
	462	Read (K);
0873bafc GB	463
	464	declare
	465	Returned_Value : constant String := Result (1 .. Result_Last);
	466
	467	begin
	468	OS_Lib.Free (Result);
	469	return Returned_Value;
	470	end;
38cbfe40 RK	471	end;
	472	end Expand_Path;
	473
	474	--------------------
	475	-- File_Extension --
	476	--------------------
	477
	478	function File_Extension (Path : Path_Name) return String is
	479	First : Natural :=
	480	Strings.Fixed.Index
	481	(Path, Dir_Seps, Going => Strings.Backward);
	482
	483	Dot : Natural;
	484
	485	begin
	486	if First = 0 then
	487	First := Path'First;
	488	end if;
	489
	490	Dot := Strings.Fixed.Index (Path (First .. Path'Last),
	491	".",
	492	Going => Strings.Backward);
	493
	494	if Dot = 0 or else Dot = Path'Last then
	495	return "";
	496	else
	497	return Path (Dot .. Path'Last);
	498	end if;
	499	end File_Extension;
	500
	501	---------------
	502	-- File_Name --
	503	---------------
	504
	505	function File_Name (Path : Path_Name) return String is
	506	begin
	507	return Base_Name (Path);
	508	end File_Name;
	509
07fc65c4 GB	510	---------------------
	511	-- Format_Pathname --
	512	---------------------
	513
	514	function Format_Pathname
	515	(Path : Path_Name;
	516	Style : Path_Style := System_Default)
	517	return String
	518	is
fbf5a39b AC	519	N_Path : String := Path;
	520	K : Positive := N_Path'First;
	521	Prev_Dirsep : Boolean := False;
07fc65c4 GB	522
07fc65c4 GB	523	begin
fbf5a39b AC	524	if Dir_Separator = '\'
	525	and then Path'Length > 1
	526	and then Path (K .. K + 1) = "\\"
	527	then
	528	if Style = UNIX then
	529	N_Path (K .. K + 1) := "//";
	530	end if;
07fc65c4	531
fbf5a39b AC	532	K := K + 2;
	533	end if;
	534
	535	for J in K .. Path'Last loop
07fc65c4 GB	536	if Strings.Maps.Is_In (Path (J), Dir_Seps) then
	537	if not Prev_Dirsep then
	538	case Style is
	539	when UNIX => N_Path (K) := '/';
	540	when DOS => N_Path (K) := '\';
	541	when System_Default => N_Path (K) := Dir_Separator;
	542	end case;
	543
	544	K := K + 1;
	545	end if;
	546
	547	Prev_Dirsep := True;
	548
	549	else
	550	N_Path (K) := Path (J);
	551	K := K + 1;
	552	Prev_Dirsep := False;
	553	end if;
	554	end loop;
	555
	556	return N_Path (N_Path'First .. K - 1);
	557	end Format_Pathname;
	558
38cbfe40 RK	559	---------------------
	560	-- Get_Current_Dir --
	561	---------------------
	562
	563	Max_Path : Integer;
019310ac	564	pragma Import (C, Max_Path, "__gnat_max_path_len");
38cbfe40 RK	565
	566	function Get_Current_Dir return Dir_Name_Str is
	567	Current_Dir : String (1 .. Max_Path + 1);
	568	Last : Natural;
	569
	570	begin
	571	Get_Current_Dir (Current_Dir, Last);
	572	return Current_Dir (1 .. Last);
	573	end Get_Current_Dir;
	574
	575	procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
	576	Path_Len : Natural := Max_Path;
	577	Buffer : String (Dir'First .. Dir'First + Max_Path + 1);
	578
	579	procedure Local_Get_Current_Dir
	580	(Dir : System.Address;
	581	Length : System.Address);
	582	pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
	583
	584	begin
	585	Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
	586
	587	if Dir'Length > Path_Len then
	588	Last := Dir'First + Path_Len - 1;
	589	else
	590	Last := Dir'Last;
	591	end if;
	592
	593	Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
	594	end Get_Current_Dir;
	595
	596	-------------
	597	-- Is_Open --
	598	-------------
	599
	600	function Is_Open (Dir : Dir_Type) return Boolean is
	601	begin
	602	return Dir /= Null_Dir
	603	and then System.Address (Dir.all) /= System.Null_Address;
	604	end Is_Open;
	605
	606	--------------
	607	-- Make_Dir --
	608	--------------
	609
	610	procedure Make_Dir (Dir_Name : Dir_Name_Str) is
fbf5a39b	611	C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
38cbfe40 RK	612
	613	function mkdir (Dir_Name : String) return Integer;
	614	pragma Import (C, mkdir, "__gnat_mkdir");
	615
	616	begin
	617	if mkdir (C_Dir_Name) /= 0 then
	618	raise Directory_Error;
	619	end if;
	620	end Make_Dir;
	621
38cbfe40 RK	622	----------
	623	-- Open --
	624	----------
	625
	626	procedure Open
	627	(Dir : out Dir_Type;
	628	Dir_Name : Dir_Name_Str)
	629	is
fbf5a39b	630	C_File_Name : constant String := Dir_Name & ASCII.NUL;
38cbfe40 RK	631
	632	function opendir
	633	(File_Name : String)
	634	return Dir_Type_Value;
	635	pragma Import (C, opendir, "opendir");
	636
	637	begin
	638	Dir := new Dir_Type_Value'(opendir (C_File_Name));
	639
	640	if not Is_Open (Dir) then
	641	Free (Dir);
	642	Dir := Null_Dir;
	643	raise Directory_Error;
	644	end if;
	645	end Open;
	646
	647	----------
	648	-- Read --
	649	----------
	650
	651	procedure Read
	652	(Dir : in out Dir_Type;
	653	Str : out String;
	654	Last : out Natural)
	655	is
	656	Filename_Addr : Address;
	657	Filename_Len : Integer;
	658
fbf5a39b AC	659	Buffer : array (0 .. Filename_Max + 12) of Character;
	660	-- 12 is the size of the dirent structure (see dirent.h), without the
	661	-- field for the filename.
38cbfe40 RK	662
	663	function readdir_gnat
	664	(Directory : System.Address;
	665	Buffer : System.Address)
	666	return System.Address;
	667	pragma Import (C, readdir_gnat, "__gnat_readdir");
	668
	669	function strlen (S : Address) return Integer;
	670	pragma Import (C, strlen, "strlen");
	671
	672	begin
	673	if not Is_Open (Dir) then
	674	raise Directory_Error;
	675	end if;
	676
	677	Filename_Addr :=
	678	readdir_gnat (System.Address (Dir.all), Buffer'Address);
	679
	680	if Filename_Addr = System.Null_Address then
	681	Last := 0;
	682	return;
	683	end if;
	684
	685	Filename_Len := strlen (Filename_Addr);
	686
	687	if Str'Length > Filename_Len then
	688	Last := Str'First + Filename_Len - 1;
	689	else
	690	Last := Str'Last;
	691	end if;
	692
	693	declare
	694	subtype Path_String is String (1 .. Filename_Len);
	695	type Path_String_Access is access Path_String;
	696
	697	function Address_To_Access is new
	698	Unchecked_Conversion
	699	(Source => Address,
	700	Target => Path_String_Access);
	701
fbf5a39b AC	702	Path_Access : constant Path_String_Access :=
fbf5a39b AC	703	Address_To_Access (Filename_Addr);
38cbfe40 RK	704
	705	begin
	706	for J in Str'First .. Last loop
	707	Str (J) := Path_Access (J - Str'First + 1);
	708	end loop;
	709	end;
	710	end Read;
	711
	712	-------------------------
	713	-- Read_Is_Thread_Sage --
	714	-------------------------
	715
	716	function Read_Is_Thread_Safe return Boolean is
	717
	718	function readdir_is_thread_safe return Integer;
	719	pragma Import
	720	(C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
	721
	722	begin
	723	return (readdir_is_thread_safe /= 0);
	724	end Read_Is_Thread_Safe;
	725
	726	----------------
	727	-- Remove_Dir --
	728	----------------
	729
fbf5a39b AC	730	procedure Remove_Dir
	731	(Dir_Name : Dir_Name_Str;
	732	Recursive : Boolean := False)
	733	is
	734	C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
	735	Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
	736	Last : Integer;
	737	Str : String (1 .. Filename_Max);
	738	Success : Boolean;
	739	Working_Dir : Dir_Type;
38cbfe40 RK	740
	741	procedure rmdir (Dir_Name : String);
	742	pragma Import (C, rmdir, "rmdir");
	743
	744	begin
fbf5a39b AC	745	-- Remove the directory only if it is empty
	746
	747	if not Recursive then
	748	rmdir (C_Dir_Name);
	749
	750	if GNAT.OS_Lib.Is_Directory (Dir_Name) then
	751	raise Directory_Error;
	752	end if;
	753
	754	-- Remove directory and all files and directories that it may contain
	755
	756	else
	757	Change_Dir (Dir_Name);
	758	Open (Working_Dir, ".");
	759
	760	loop
	761	Read (Working_Dir, Str, Last);
	762	exit when Last = 0;
	763
	764	if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
	765	if Str (1 .. Last) /= "." and then Str (1 .. Last) /= ".." then
	766	Remove_Dir (Str (1 .. Last), True);
	767	Remove_Dir (Str (1 .. Last));
	768	end if;
	769
	770	else
	771	GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
	772
	773	if not Success then
	774	Change_Dir (Current_Dir);
	775	raise Directory_Error;
	776	end if;
	777	end if;
	778	end loop;
	779
	780	Change_Dir (Current_Dir);
	781	Close (Working_Dir);
	782	Remove_Dir (Dir_Name);
	783	end if;
38cbfe40 RK	784	end Remove_Dir;
38cbfe40 RK	785
38cbfe40	786	end GNAT.Directory_Operations;