Subversion Repositories openrisc_2011-10-31

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

--                                                                          --

--                         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-2009, 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.Unchecked_Deallocation;

with Ada.Unchecked_Conversion;

with System;      use System;

with System.CRTL; use System.CRTL;

with GNAT.OS_Lib;

package body GNAT.Directory_Operations is

   use Ada;

   Filename_Max : constant Integer := 1024;

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

   procedure Free is new

     Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type);

   On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\';

   --  An indication that we are on Windows. Used in Get_Current_Dir, to

   --  deal with drive letters in the beginning of absolute paths.

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

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

         Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);

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

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

      function closedir (directory : DIRs) return Integer;

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

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

      Last :=

        (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last);

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

      --  By default, the drive letter on Windows is in upper case

      if On_Windows and then Last > Dir'First and then

        Dir (Dir'First + 1) = ':'

      then

         Dir (Dir'First) :=

           Ada.Characters.Handling.To_Upper (Dir (Dir'First));

      end if;

   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

      function opendir (file_name : String) return DIRs;

      pragma Import (C, opendir, "__gnat_opendir");

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

      Str  : out String;

      Last : out Natural)

   is

      Filename_Addr : Address;

      Filename_Len  : aliased 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;

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

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

   begin

      if not Is_Open (Dir) then

         raise Directory_Error;

      end if;

      Filename_Addr :=

        readdir_gnat

          (System.Address (Dir.all), Buffer'Address, Filename_Len'Access);

      if Filename_Addr = System.Null_Address then

         Last := 0;

         return;

      end if;

      Last :=

        (if Str'Length > Filename_Len then Str'First + Filename_Len - 1

         else Str'Last);

      declare

         subtype Path_String is String (1 .. Filename_Len);

         type    Path_String_Access is access Path_String;

         function Address_To_Access is new

           Ada.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

         if rmdir (C_Dir_Name) /= 0 then

            raise Directory_Error;

         end if;

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

      else

         --  Substantial comments needed. See RH for revision 1.50 ???

         begin

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

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