URL https://opencores.org/ocsvn/scarts/scarts/trunk

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [g-dirope.adb] - Blame information for rev 20

Go to most recent revision | Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         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-2005, AdaCore                     --
--                                                                          --
-- 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,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, 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 System.CRTL; use System.CRTL;
 
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
 
            Has_Drive_Letter : constant Boolean :=
                                 OS_Lib.Path_Separator /= ':';
            --  If Path separator is not ':' then we are on a DOS based OS
            --  where this character is used as a drive letter separator.
 
         begin
            if BN = "." or else BN = ".." then
               return "";
 
            elsif Has_Drive_Letter
              and then 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
      Discard : Integer;
      pragma Warnings (Off, Discard);
 
   begin
      if not Is_Open (Dir) then
         raise Directory_Error;
      end if;
 
      Discard := closedir (DIRs (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;
 
   begin
      Dir := new Dir_Type_Value'(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;
 
   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;

Browse

Tools

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [g-dirope.adb] - Blame information for rev 20

Line No.	Rev	Author	Line
1	12	jlechner	`------------------------------------------------------------------------------`
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			`-- --`
9			`-- Copyright (C) 1998-2005, AdaCore --`
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, 51 Franklin Street, Fifth Floor, --`
20			`-- Boston, MA 02110-1301, 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			`-- --`
29			`-- GNAT was originally developed by the GNAT team at New York University. --`
30			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
31			`-- --`
32			`------------------------------------------------------------------------------`
33
34			`with Ada.Characters.Handling;`
35			`with Ada.Strings.Fixed;`
36			`with Ada.Strings.Maps;`
37
38			`with Unchecked_Deallocation;`
39			`with Unchecked_Conversion;`
40
41			`with System; use System;`
42			`with System.CRTL; use System.CRTL;`
43
44			`with GNAT.OS_Lib;`
45
46			`package body GNAT.Directory_Operations is`
47
48			`use Ada;`
49
50			`type Dir_Type_Value is new System.Address;`
51			`-- This is the low-level address directory structure as returned by the C`
52			`-- opendir routine.`
53
54			`Filename_Max : constant Integer := 1024;`
55			`-- 1024 is the value of FILENAME_MAX in stdio.h`
56
57			`procedure Free is new`
58			`Unchecked_Deallocation (Dir_Type_Value, Dir_Type);`
59
60			`---------------`
61			`-- Base_Name --`
62			`---------------`
63
64			`function Base_Name`
65			`(Path : Path_Name;`
66			`Suffix : String := "") return String`
67			`is`
68			`function Get_File_Names_Case_Sensitive return Integer;`
69			`pragma Import`
70			`(C, Get_File_Names_Case_Sensitive,`
71			`"__gnat_get_file_names_case_sensitive");`
72
73			`Case_Sensitive_File_Name : constant Boolean :=`
74			`Get_File_Names_Case_Sensitive = 1;`
75
76			`function Basename`
77			`(Path : Path_Name;`
78			`Suffix : String := "") return String;`
79			`-- This function does the job. The only difference between Basename`
80			`-- and Base_Name (the parent function) is that the former is case`
81			`-- sensitive, while the latter is not. Path and Suffix are adjusted`
82			`-- appropriately before calling Basename under platforms where the`
83			`-- file system is not case sensitive.`
84
85			`--------------`
86			`-- Basename --`
87			`--------------`
88
89			`function Basename`
90			`(Path : Path_Name;`
91			`Suffix : String := "") 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`
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`
125
126			`Has_Drive_Letter : constant Boolean :=`
127			`OS_Lib.Path_Separator /= ':';`
128			`-- If Path separator is not ':' then we are on a DOS based OS`
129			`-- where this character is used as a drive letter separator.`
130
131			`begin`
132			`if BN = "." or else BN = ".." then`
133			`return "";`
134
135			`elsif Has_Drive_Letter`
136			`and then BN'Length > 2`
137			`and then Characters.Handling.Is_Letter (BN (BN'First))`
138			`and then BN (BN'First + 1) = ':'`
139			`then`
140			`-- We have a DOS drive letter prefix, remove it`
141
142			`return BN (BN'First + 2 .. BN'Last);`
143
144			`else`
145			`return BN;`
146			`end if;`
147			`end Check_For_Standard_Dirs;`
148			`end Basename;`
149
150			`-- Start processing for Base_Name`
151
152			`begin`
153			`if Path'Length <= Suffix'Length then`
154			`return Path;`
155			`end if;`
156
157			`if Case_Sensitive_File_Name then`
158			`return Basename (Path, Suffix);`
159			`else`
160			`return Basename`
161			`(Characters.Handling.To_Lower (Path),`
162			`Characters.Handling.To_Lower (Suffix));`
163			`end if;`
164			`end Base_Name;`
165
166			`----------------`
167			`-- Change_Dir --`
168			`----------------`
169
170			`procedure Change_Dir (Dir_Name : Dir_Name_Str) is`
171			`C_Dir_Name : constant String := Dir_Name & ASCII.NUL;`
172
173			`function chdir (Dir_Name : String) return Integer;`
174			`pragma Import (C, chdir, "chdir");`
175
176			`begin`
177			`if chdir (C_Dir_Name) /= 0 then`
178			`raise Directory_Error;`
179			`end if;`
180			`end Change_Dir;`
181
182			`-----------`
183			`-- Close --`
184			`-----------`
185
186			`procedure Close (Dir : in out Dir_Type) is`
187			`Discard : Integer;`
188			`pragma Warnings (Off, Discard);`
189
190			`begin`
191			`if not Is_Open (Dir) then`
192			`raise Directory_Error;`
193			`end if;`
194
195			`Discard := closedir (DIRs (Dir.all));`
196			`Free (Dir);`
197			`end Close;`
198
199			`--------------`
200			`-- Dir_Name --`
201			`--------------`
202
203			`function Dir_Name (Path : Path_Name) return Dir_Name_Str is`
204			`Last_DS : constant Natural :=`
205			`Strings.Fixed.Index`
206			`(Path, Dir_Seps, Going => Strings.Backward);`
207
208			`begin`
209			`if Last_DS = 0 then`
210
211			`-- There is no directory separator, returns current working directory`
212
213			`return "." & Dir_Separator;`
214
215			`else`
216			`return Path (Path'First .. Last_DS);`
217			`end if;`
218			`end Dir_Name;`
219
220			`-----------------`
221			`-- Expand_Path --`
222			`-----------------`
223
224			`function Expand_Path`
225			`(Path : Path_Name;`
226			`Mode : Environment_Style := System_Default) return Path_Name`
227			`is`
228			`Environment_Variable_Char : Character;`
229			`pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");`
230
231			`Result : OS_Lib.String_Access := new String (1 .. 200);`
232			`Result_Last : Natural := 0;`
233
234			`procedure Append (C : Character);`
235			`procedure Append (S : String);`
236			`-- Append to Result`
237
238			`procedure Double_Result_Size;`
239			`-- Reallocate Result, doubling its size`
240
241			`function Is_Var_Prefix (C : Character) return Boolean;`
242			`pragma Inline (Is_Var_Prefix);`
243
244			`procedure Read (K : in out Positive);`
245			`-- Update Result while reading current Path starting at position K. If`
246			`-- a variable is found, call Var below.`
247
248			`procedure Var (K : in out Positive);`
249			`-- Translate variable name starting at position K with the associated`
250			`-- environment value.`
251
252			`------------`
253			`-- Append --`
254			`------------`
255
256			`procedure Append (C : Character) is`
257			`begin`
258			`if Result_Last = Result'Last then`
259			`Double_Result_Size;`
260			`end if;`
261
262			`Result_Last := Result_Last + 1;`
263			`Result (Result_Last) := C;`
264			`end Append;`
265
266			`procedure Append (S : String) is`
267			`begin`
268			`while Result_Last + S'Length - 1 > Result'Last loop`
269			`Double_Result_Size;`
270			`end loop;`
271
272			`Result (Result_Last + 1 .. Result_Last + S'Length) := S;`
273			`Result_Last := Result_Last + S'Length;`
274			`end Append;`
275
276			`------------------------`
277			`-- Double_Result_Size --`
278			`------------------------`
279
280			`procedure Double_Result_Size is`
281			`New_Result : constant OS_Lib.String_Access :=`
282			`new String (1 .. 2 * Result'Last);`
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;`
288
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
302			`----------`
303			`-- Read --`
304			`----------`
305
306			`procedure Read (K : in out Positive) is`
307			`P : Character;`
308
309			`begin`
310			`For_All_Characters : loop`
311			`if Is_Var_Prefix (Path (K)) then`
312			`P := Path (K);`
313
314			`-- Could be a variable`
315
316			`if K < Path'Last then`
317			`if Path (K + 1) = P then`
318
319			`-- Not a variable after all, this is a double $ or %,`
320			`-- just insert one in the result string.`
321
322			`Append (P);`
323			`K := K + 1;`
324
325			`else`
326			`-- Let's parse the variable`
327
328			`Var (K);`
329			`end if;`
330
331			`else`
332			`-- We have an ending $ or % sign`
333
334			`Append (P);`
335			`end if;`
336
337			`else`
338			`-- This is a standard character, just add it to the result`
339
340			`Append (Path (K));`
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`
356			`P : constant Character := Path (K);`
357			`T : Character;`
358			`E : Positive;`
359
360			`begin`
361			`K := K + 1;`
362
363			`if P = '%' or else Path (K) = '{' then`
364
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.`
376
377			`E := K;`
378
379			`loop`
380			`E := E + 1;`
381			`exit when Path (E) = T or else E = Path'Last;`
382			`end loop;`
383
384			`if Path (E) = T then`
385
386			`-- OK found, translate with environment value`
387
388			`declare`
389			`Env : OS_Lib.String_Access :=`
390			`OS_Lib.Getenv (Path (K .. E - 1));`
391
392			`begin`
393			`Append (Env.all);`
394			`OS_Lib.Free (Env);`
395			`end;`
396
397			`else`
398			`-- No terminator character, not a variable after all or a`
399			`-- syntax error, ignore it, insert string as-is.`
400
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
407			`Append (Path (K .. E));`
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`
422			`exit Var_Name when E > Path'Last;`
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`
429			`exit Var_Name;`
430			`end if;`
431			`end loop Var_Name;`
432
433			`E := E - 1;`
434
435			`declare`
436			`Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));`
437
438			`begin`
439			`Append (Env.all);`
440			`OS_Lib.Free (Env);`
441			`end;`
442
443			`else`
444			`-- This is not a variable after all`
445
446			`Append ('$');`
447			`Append (Path (E));`
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);`
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;`
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
510			`---------------------`
511			`-- Format_Pathname --`
512			`---------------------`
513
514			`function Format_Pathname`
515			`(Path : Path_Name;`
516			`Style : Path_Style := System_Default) return String`
517			`is`
518			`N_Path : String := Path;`
519			`K : Positive := N_Path'First;`
520			`Prev_Dirsep : Boolean := False;`
521
522			`begin`
523			`if Dir_Separator = '\'`
524			`and then Path'Length > 1`
525			`and then Path (K .. K + 1) = "\\"`
526			`then`
527			`if Style = UNIX then`
528			`N_Path (K .. K + 1) := "//";`
529			`end if;`
530
531			`K := K + 2;`
532			`end if;`
533
534			`for J in K .. Path'Last loop`
535			`if Strings.Maps.Is_In (Path (J), Dir_Seps) then`
536			`if not Prev_Dirsep then`
537			`case Style is`
538			`when UNIX => N_Path (K) := '/';`
539			`when DOS => N_Path (K) := '\';`
540			`when System_Default => N_Path (K) := Dir_Separator;`
541			`end case;`
542
543			`K := K + 1;`
544			`end if;`
545
546			`Prev_Dirsep := True;`
547
548			`else`
549			`N_Path (K) := Path (J);`
550			`K := K + 1;`
551			`Prev_Dirsep := False;`
552			`end if;`
553			`end loop;`
554
555			`return N_Path (N_Path'First .. K - 1);`
556			`end Format_Pathname;`
557
558			`---------------------`
559			`-- Get_Current_Dir --`
560			`---------------------`
561
562			`Max_Path : Integer;`
563			`pragma Import (C, Max_Path, "__gnat_max_path_len");`
564
565			`function Get_Current_Dir return Dir_Name_Str is`
566			`Current_Dir : String (1 .. Max_Path + 1);`
567			`Last : Natural;`
568			`begin`
569			`Get_Current_Dir (Current_Dir, Last);`
570			`return Current_Dir (1 .. Last);`
571			`end Get_Current_Dir;`
572
573			`procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is`
574			`Path_Len : Natural := Max_Path;`
575			`Buffer : String (Dir'First .. Dir'First + Max_Path + 1);`
576
577			`procedure Local_Get_Current_Dir`
578			`(Dir : System.Address;`
579			`Length : System.Address);`
580			`pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");`
581
582			`begin`
583			`Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);`
584
585			`if Dir'Length > Path_Len then`
586			`Last := Dir'First + Path_Len - 1;`
587			`else`
588			`Last := Dir'Last;`
589			`end if;`
590
591			`Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);`
592			`end Get_Current_Dir;`
593
594			`-------------`
595			`-- Is_Open --`
596			`-------------`
597
598			`function Is_Open (Dir : Dir_Type) return Boolean is`
599			`begin`
600			`return Dir /= Null_Dir`
601			`and then System.Address (Dir.all) /= System.Null_Address;`
602			`end Is_Open;`
603
604			`--------------`
605			`-- Make_Dir --`
606			`--------------`
607
608			`procedure Make_Dir (Dir_Name : Dir_Name_Str) is`
609			`C_Dir_Name : constant String := Dir_Name & ASCII.NUL;`
610
611			`function mkdir (Dir_Name : String) return Integer;`
612			`pragma Import (C, mkdir, "__gnat_mkdir");`
613
614			`begin`
615			`if mkdir (C_Dir_Name) /= 0 then`
616			`raise Directory_Error;`
617			`end if;`
618			`end Make_Dir;`
619
620			`----------`
621			`-- Open --`
622			`----------`
623
624			`procedure Open`
625			`(Dir : out Dir_Type;`
626			`Dir_Name : Dir_Name_Str)`
627			`is`
628			`C_File_Name : constant String := Dir_Name & ASCII.NUL;`
629
630			`begin`
631			`Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name)));`
632
633			`if not Is_Open (Dir) then`
634			`Free (Dir);`
635			`Dir := Null_Dir;`
636			`raise Directory_Error;`
637			`end if;`
638			`end Open;`
639
640			`----------`
641			`-- Read --`
642			`----------`
643
644			`procedure Read`
645			`(Dir : in out Dir_Type;`
646			`Str : out String;`
647			`Last : out Natural)`
648			`is`
649			`Filename_Addr : Address;`
650			`Filename_Len : Integer;`
651
652			`Buffer : array (0 .. Filename_Max + 12) of Character;`
653			`-- 12 is the size of the dirent structure (see dirent.h), without the`
654			`-- field for the filename.`
655
656			`function readdir_gnat`
657			`(Directory : System.Address;`
658			`Buffer : System.Address) return System.Address;`
659			`pragma Import (C, readdir_gnat, "__gnat_readdir");`
660
661			`function strlen (S : Address) return Integer;`
662			`pragma Import (C, strlen, "strlen");`
663
664			`begin`
665			`if not Is_Open (Dir) then`
666			`raise Directory_Error;`
667			`end if;`
668
669			`Filename_Addr :=`
670			`readdir_gnat (System.Address (Dir.all), Buffer'Address);`
671
672			`if Filename_Addr = System.Null_Address then`
673			`Last := 0;`
674			`return;`
675			`end if;`
676
677			`Filename_Len := strlen (Filename_Addr);`
678
679			`if Str'Length > Filename_Len then`
680			`Last := Str'First + Filename_Len - 1;`
681			`else`
682			`Last := Str'Last;`
683			`end if;`
684
685			`declare`
686			`subtype Path_String is String (1 .. Filename_Len);`
687			`type Path_String_Access is access Path_String;`
688
689			`function Address_To_Access is new`
690			`Unchecked_Conversion`
691			`(Source => Address,`
692			`Target => Path_String_Access);`
693
694			`Path_Access : constant Path_String_Access :=`
695			`Address_To_Access (Filename_Addr);`
696
697			`begin`
698			`for J in Str'First .. Last loop`
699			`Str (J) := Path_Access (J - Str'First + 1);`
700			`end loop;`
701			`end;`
702			`end Read;`
703
704			`-------------------------`
705			`-- Read_Is_Thread_Sage --`
706			`-------------------------`
707
708			`function Read_Is_Thread_Safe return Boolean is`
709			`function readdir_is_thread_safe return Integer;`
710			`pragma Import`
711			`(C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");`
712			`begin`
713			`return (readdir_is_thread_safe /= 0);`
714			`end Read_Is_Thread_Safe;`
715
716			`----------------`
717			`-- Remove_Dir --`
718			`----------------`
719
720			`procedure Remove_Dir`
721			`(Dir_Name : Dir_Name_Str;`
722			`Recursive : Boolean := False)`
723			`is`
724			`C_Dir_Name : constant String := Dir_Name & ASCII.NUL;`
725			`Current_Dir : constant Dir_Name_Str := Get_Current_Dir;`
726			`Last : Integer;`
727			`Str : String (1 .. Filename_Max);`
728			`Success : Boolean;`
729			`Working_Dir : Dir_Type;`
730
731			`begin`
732			`-- Remove the directory only if it is empty`
733
734			`if not Recursive then`
735			`rmdir (C_Dir_Name);`
736
737			`if GNAT.OS_Lib.Is_Directory (Dir_Name) then`
738			`raise Directory_Error;`
739			`end if;`
740
741			`-- Remove directory and all files and directories that it may contain`
742
743			`else`
744			`Change_Dir (Dir_Name);`
745			`Open (Working_Dir, ".");`
746
747			`loop`
748			`Read (Working_Dir, Str, Last);`
749			`exit when Last = 0;`
750
751			`if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then`
752			`if Str (1 .. Last) /= "." and then Str (1 .. Last) /= ".." then`
753			`Remove_Dir (Str (1 .. Last), True);`
754			`Remove_Dir (Str (1 .. Last));`
755			`end if;`
756
757			`else`
758			`GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);`
759
760			`if not Success then`
761			`Change_Dir (Current_Dir);`
762			`raise Directory_Error;`
763			`end if;`
764			`end if;`
765			`end loop;`
766
767			`Change_Dir (Current_Dir);`
768			`Close (Working_Dir);`
769			`Remove_Dir (Dir_Name);`
770			`end if;`
771			`end Remove_Dir;`
772
773			`end GNAT.Directory_Operations;`