diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/a-direct.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/a-direct.adb | 989 |
1 files changed, 989 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/a-direct.adb b/gcc-4.2.1/gcc/ada/a-direct.adb new file mode 100644 index 000000000..2cd29ed38 --- /dev/null +++ b/gcc-4.2.1/gcc/ada/a-direct.adb @@ -0,0 +1,989 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2005, Free Software Foundation, 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, 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.Directories.Validity; use Ada.Directories.Validity; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Unchecked_Deallocation; +with Ada.Unchecked_Conversion; +with Ada.Characters.Handling; use Ada.Characters.Handling; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Regexp; use GNAT.Regexp; +-- ??? Ada units should not depend on GNAT units + +with System; + +package body Ada.Directories is + + function Duration_To_Time is new + Ada.Unchecked_Conversion (Duration, Ada.Calendar.Time); + function OS_Time_To_Long_Integer is new + Ada.Unchecked_Conversion (OS_Time, Long_Integer); + -- These two unchecked conversions are used in function Modification_Time + -- to convert an OS_Time to a Calendar.Time. + + type Search_Data is record + Is_Valid : Boolean := False; + Name : Ada.Strings.Unbounded.Unbounded_String; + Pattern : Regexp; + Filter : Filter_Type; + Dir : Dir_Type; + Entry_Fetched : Boolean := False; + Dir_Entry : Directory_Entry_Type; + end record; + -- The current state of a search + + Empty_String : constant String := (1 .. 0 => ASCII.NUL); + -- Empty string, returned by function Extension when there is no extension + + procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr); + + function File_Exists (Name : String) return Boolean; + -- Returns True if the named file exists + + procedure Fetch_Next_Entry (Search : Search_Type); + -- Get the next entry in a directory, setting Entry_Fetched if successful + -- or resetting Is_Valid if not. + + procedure To_Lower_If_Case_Insensitive (S : in out String); + -- Put S in lower case if file and path names are case-insensitive + + --------------- + -- Base_Name -- + --------------- + + function Base_Name (Name : String) return String is + Simple : String := Simple_Name (Name); + -- Simple'First is guaranteed to be 1 + + begin + To_Lower_If_Case_Insensitive (Simple); + + -- Look for the last dot in the file name and return the part of the + -- file name preceding this last dot. If the first dot is the first + -- character of the file name, the base name is the empty string. + + for Pos in reverse Simple'Range loop + if Simple (Pos) = '.' then + return Simple (1 .. Pos - 1); + end if; + end loop; + + -- If there is no dot, return the complete file name + + return Simple; + end Base_Name; + + ------------- + -- Compose -- + ------------- + + function Compose + (Containing_Directory : String := ""; + Name : String; + Extension : String := "") return String + is + Result : String (1 .. Containing_Directory'Length + + Name'Length + Extension'Length + 2); + Last : Natural; + + begin + -- First, deal with the invalid cases + + if not Is_Valid_Path_Name (Containing_Directory) then + raise Name_Error; + + elsif + Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name)) + then + raise Name_Error; + + elsif Extension'Length /= 0 and then + (not Is_Valid_Simple_Name (Name & '.' & Extension)) + then + raise Name_Error; + + -- This is not an invalid case so build the path name + + else + Last := Containing_Directory'Length; + Result (1 .. Last) := Containing_Directory; + + -- Add a directory separator if needed + + if Result (Last) /= Dir_Separator then + Last := Last + 1; + Result (Last) := Dir_Separator; + end if; + + -- Add the file name + + Result (Last + 1 .. Last + Name'Length) := Name; + Last := Last + Name'Length; + + -- If extension was specified, add dot followed by this extension + + if Extension'Length /= 0 then + Last := Last + 1; + Result (Last) := '.'; + Result (Last + 1 .. Last + Extension'Length) := Extension; + Last := Last + Extension'Length; + end if; + + To_Lower_If_Case_Insensitive (Result (1 .. Last)); + return Result (1 .. Last); + end if; + end Compose; + + -------------------------- + -- Containing_Directory -- + -------------------------- + + function Containing_Directory (Name : String) return String is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error; + + else + -- Get the directory name using GNAT.Directory_Operations.Dir_Name + + declare + Value : constant String := Dir_Name (Path => Name); + Result : String (1 .. Value'Length); + Last : Natural := Result'Last; + + begin + Result := Value; + + -- Remove any trailing directory separator, except as the first + -- character. + + while Last > 1 and then Result (Last) = Dir_Separator loop + Last := Last - 1; + end loop; + + -- Special case of current directory, identified by "." + + if Last = 1 and then Result (1) = '.' then + return Get_Current_Dir; + + else + To_Lower_If_Case_Insensitive (Result (1 .. Last)); + return Result (1 .. Last); + end if; + end; + end if; + end Containing_Directory; + + --------------- + -- Copy_File -- + --------------- + + procedure Copy_File + (Source_Name : String; + Target_Name : String; + Form : String := "") + is + pragma Unreferenced (Form); + Success : Boolean; + + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Source_Name) + or else not Is_Valid_Path_Name (Target_Name) + or else not Is_Regular_File (Source_Name) + then + raise Name_Error; + + elsif Is_Directory (Target_Name) then + raise Use_Error; + + else + -- The implementation uses GNAT.OS_Lib.Copy_File, with parameters + -- suitable for all platforms. + + Copy_File + (Source_Name, Target_Name, Success, Overwrite, None); + + if not Success then + raise Use_Error; + end if; + end if; + end Copy_File; + + ---------------------- + -- Create_Directory -- + ---------------------- + + procedure Create_Directory + (New_Directory : String; + Form : String := "") + is + pragma Unreferenced (Form); + + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (New_Directory) then + raise Name_Error; + + else + -- The implementation uses GNAT.Directory_Operations.Make_Dir + + begin + Make_Dir (Dir_Name => New_Directory); + + exception + when Directory_Error => + raise Use_Error; + end; + end if; + end Create_Directory; + + ----------------- + -- Create_Path -- + ----------------- + + procedure Create_Path + (New_Directory : String; + Form : String := "") + is + pragma Unreferenced (Form); + + New_Dir : String (1 .. New_Directory'Length + 1); + Last : Positive := 1; + + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (New_Directory) then + raise Name_Error; + + else + -- Build New_Dir with a directory separator at the end, so that the + -- complete path will be found in the loop below. + + New_Dir (1 .. New_Directory'Length) := New_Directory; + New_Dir (New_Dir'Last) := Directory_Separator; + + -- Create, if necessary, each directory in the path + + for J in 2 .. New_Dir'Last loop + + -- Look for the end of an intermediate directory + + if New_Dir (J) /= Dir_Separator then + Last := J; + + -- We have found a new intermediate directory each time we find + -- a first directory separator. + + elsif New_Dir (J - 1) /= Dir_Separator then + + -- No need to create the directory if it already exists + + if Is_Directory (New_Dir (1 .. Last)) then + null; + + -- It is an error if a file with such a name already exists + + elsif Is_Regular_File (New_Dir (1 .. Last)) then + raise Use_Error; + + else + -- The implementation uses + -- GNAT.Directory_Operations.Make_Dir. + + begin + Make_Dir (Dir_Name => New_Dir (1 .. Last)); + + exception + when Directory_Error => + raise Use_Error; + end; + end if; + end if; + end loop; + end if; + end Create_Path; + + ----------------------- + -- Current_Directory -- + ----------------------- + + function Current_Directory return String is + + -- The implementation uses GNAT.Directory_Operations.Get_Current_Dir + + Cur : String := Normalize_Pathname (Get_Current_Dir); + + begin + To_Lower_If_Case_Insensitive (Cur); + + if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then + return Cur (1 .. Cur'Last - 1); + else + return Cur; + end if; + end Current_Directory; + + ---------------------- + -- Delete_Directory -- + ---------------------- + + procedure Delete_Directory (Directory : String) is + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Directory) then + raise Name_Error; + + elsif not Is_Directory (Directory) then + raise Name_Error; + + else + -- The implementation uses GNAT.Directory_Operations.Remove_Dir + + begin + Remove_Dir (Dir_Name => Directory, Recursive => False); + + exception + when Directory_Error => + raise Use_Error; + end; + end if; + end Delete_Directory; + + ----------------- + -- Delete_File -- + ----------------- + + procedure Delete_File (Name : String) is + Success : Boolean; + + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Name) then + raise Name_Error; + + elsif not Is_Regular_File (Name) then + raise Name_Error; + + else + -- The implementation uses GNAT.OS_Lib.Delete_File + + Delete_File (Name, Success); + + if not Success then + raise Use_Error; + end if; + end if; + end Delete_File; + + ----------------- + -- Delete_Tree -- + ----------------- + + procedure Delete_Tree (Directory : String) is + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Directory) then + raise Name_Error; + + elsif not Is_Directory (Directory) then + raise Name_Error; + + else + -- The implementation uses GNAT.Directory_Operations.Remove_Dir + + begin + Remove_Dir (Directory, Recursive => True); + + exception + when Directory_Error => + raise Use_Error; + end; + end if; + end Delete_Tree; + + ------------ + -- Exists -- + ------------ + + function Exists (Name : String) return Boolean is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error; + + else + -- The implementation is in File_Exists + + return File_Exists (Name); + end if; + end Exists; + + --------------- + -- Extension -- + --------------- + + function Extension (Name : String) return String is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error; + + else + -- Look for first dot that is not followed by a directory separator + + for Pos in reverse Name'Range loop + + -- If a directory separator is found before a dot, there + -- is no extension. + + if Name (Pos) = Dir_Separator then + return Empty_String; + + elsif Name (Pos) = '.' then + + -- We found a dot, build the return value with lower bound 1 + + declare + Result : String (1 .. Name'Last - Pos); + begin + Result := Name (Pos + 1 .. Name'Last); + return Result; + -- This should be done with a subtype conversion, avoiding + -- the unnecessary junk copy ??? + end; + end if; + end loop; + + -- No dot were found, there is no extension + + return Empty_String; + end if; + end Extension; + + ---------------------- + -- Fetch_Next_Entry -- + ---------------------- + + procedure Fetch_Next_Entry (Search : Search_Type) is + Name : String (1 .. 255); + Last : Natural; + + Kind : File_Kind := Ordinary_File; + -- Initialized to avoid a compilation warning + + begin + -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called + + loop + Read (Search.Value.Dir, Name, Last); + + -- If no matching entry is found, set Is_Valid to False + + if Last = 0 then + Search.Value.Is_Valid := False; + exit; + end if; + + -- Check if the entry matches the pattern + + if Match (Name (1 .. Last), Search.Value.Pattern) then + declare + Full_Name : constant String := + Compose + (To_String + (Search.Value.Name), Name (1 .. Last)); + Found : Boolean := False; + + begin + if File_Exists (Full_Name) then + + -- Now check if the file kind matches the filter + + if Is_Regular_File (Full_Name) then + if Search.Value.Filter (Ordinary_File) then + Kind := Ordinary_File; + Found := True; + end if; + + elsif Is_Directory (Full_Name) then + if Search.Value.Filter (Directory) then + Kind := Directory; + Found := True; + end if; + + elsif Search.Value.Filter (Special_File) then + Kind := Special_File; + Found := True; + end if; + + -- If it does, update Search and return + + if Found then + Search.Value.Entry_Fetched := True; + Search.Value.Dir_Entry := + (Is_Valid => True, + Simple => To_Unbounded_String (Name (1 .. Last)), + Full => To_Unbounded_String (Full_Name), + Kind => Kind); + exit; + end if; + end if; + end; + end if; + end loop; + end Fetch_Next_Entry; + + ----------------- + -- File_Exists -- + ----------------- + + function File_Exists (Name : String) return Boolean is + function C_File_Exists (A : System.Address) return Integer; + pragma Import (C, C_File_Exists, "__gnat_file_exists"); + + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return C_File_Exists (C_Name (1)'Address) = 1; + end File_Exists; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Search : in out Search_Type) is + begin + if Search.Value /= null then + + -- Close the directory, if one is open + + if Is_Open (Search.Value.Dir) then + Close (Search.Value.Dir); + end if; + + Free (Search.Value); + end if; + end Finalize; + + --------------- + -- Full_Name -- + --------------- + + function Full_Name (Name : String) return String is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error; + + else + -- Build the return value with lower bound 1 + + -- Use GNAT.OS_Lib.Normalize_Pathname + + declare + Value : String := Normalize_Pathname (Name); + subtype Result is String (1 .. Value'Length); + begin + To_Lower_If_Case_Insensitive (Value); + return Result (Value); + end; + end if; + end Full_Name; + + function Full_Name (Directory_Entry : Directory_Entry_Type) return String is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error; + + else + -- The value to return has already been computed + + return To_String (Directory_Entry.Full); + end if; + end Full_Name; + + -------------------- + -- Get_Next_Entry -- + -------------------- + + procedure Get_Next_Entry + (Search : in out Search_Type; + Directory_Entry : out Directory_Entry_Type) + is + begin + -- First, the invalid case + + if Search.Value = null or else not Search.Value.Is_Valid then + raise Status_Error; + end if; + + -- Fetch the next entry, if needed + + if not Search.Value.Entry_Fetched then + Fetch_Next_Entry (Search); + end if; + + -- It is an error if no valid entry is found + + if not Search.Value.Is_Valid then + raise Status_Error; + + else + -- Reset Entry_Fatched and return the entry + + Search.Value.Entry_Fetched := False; + Directory_Entry := Search.Value.Dir_Entry; + end if; + end Get_Next_Entry; + + ---------- + -- Kind -- + ---------- + + function Kind (Name : String) return File_Kind is + begin + -- First, the invalid case + + if not File_Exists (Name) then + raise Name_Error; + + elsif Is_Regular_File (Name) then + return Ordinary_File; + + elsif Is_Directory (Name) then + return Directory; + + else + return Special_File; + end if; + end Kind; + + function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error; + + else + -- The value to return has already be computed + + return Directory_Entry.Kind; + end if; + end Kind; + + ----------------------- + -- Modification_Time -- + ----------------------- + + function Modification_Time (Name : String) return Ada.Calendar.Time is + Date : OS_Time; + Year : Year_Type; + Month : Month_Type; + Day : Day_Type; + Hour : Hour_Type; + Minute : Minute_Type; + Second : Second_Type; + + Result : Ada.Calendar.Time; + + begin + -- First, the invalid cases + + if not (Is_Regular_File (Name) or else Is_Directory (Name)) then + raise Name_Error; + + else + Date := File_Time_Stamp (Name); + + -- ??? This implementation should be revisited when AI 00351 has + -- implemented. + + if OpenVMS then + + -- On OpenVMS, OS_Time is in local time + + GM_Split (Date, Year, Month, Day, Hour, Minute, Second); + + return Ada.Calendar.Time_Of + (Year, Month, Day, + Duration (Second + 60 * (Minute + 60 * Hour))); + + else + -- On Unix and Windows, OS_Time is in GMT + + Result := + Duration_To_Time (Duration (OS_Time_To_Long_Integer (Date))); + return Result; + end if; + end if; + end Modification_Time; + + function Modification_Time + (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time + is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error; + + else + -- The value to return has already be computed + + return Modification_Time (To_String (Directory_Entry.Full)); + end if; + end Modification_Time; + + ------------------ + -- More_Entries -- + ------------------ + + function More_Entries (Search : Search_Type) return Boolean is + begin + if Search.Value = null then + return False; + + elsif Search.Value.Is_Valid then + + -- Fetch the next entry, if needed + + if not Search.Value.Entry_Fetched then + Fetch_Next_Entry (Search); + end if; + end if; + + return Search.Value.Is_Valid; + end More_Entries; + + ------------ + -- Rename -- + ------------ + + procedure Rename (Old_Name, New_Name : String) is + Success : Boolean; + + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Old_Name) + or else not Is_Valid_Path_Name (New_Name) + or else (not Is_Regular_File (Old_Name) + and then not Is_Directory (Old_Name)) + then + raise Name_Error; + + elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then + raise Use_Error; + + else + -- The implementation uses GNAT.OS_Lib.Rename_File + + Rename_File (Old_Name, New_Name, Success); + + if not Success then + raise Use_Error; + end if; + end if; + end Rename; + + ------------------- + -- Set_Directory -- + ------------------- + + procedure Set_Directory (Directory : String) is + begin + -- The implementation uses GNAT.Directory_Operations.Change_Dir + + Change_Dir (Dir_Name => Directory); + + exception + when Directory_Error => + raise Name_Error; + end Set_Directory; + + ----------------- + -- Simple_Name -- + ----------------- + + function Simple_Name (Name : String) return String is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error; + + else + -- Build the value to return with lower bound 1 + + -- The implementation uses GNAT.Directory_Operations.Base_Name + + declare + Value : String := GNAT.Directory_Operations.Base_Name (Name); + subtype Result is String (1 .. Value'Length); + begin + To_Lower_If_Case_Insensitive (Value); + return Result (Value); + end; + end if; + end Simple_Name; + + function Simple_Name + (Directory_Entry : Directory_Entry_Type) return String + is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error; + + else + -- The value to return has already be computed + + return To_String (Directory_Entry.Simple); + end if; + end Simple_Name; + + ---------- + -- Size -- + ---------- + + function Size (Name : String) return File_Size is + C_Name : String (1 .. Name'Length + 1); + + function C_Size (Name : System.Address) return Long_Integer; + pragma Import (C, C_Size, "__gnat_named_file_length"); + + begin + -- First, the invalid case + + if not Is_Regular_File (Name) then + raise Name_Error; + + else + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return File_Size (C_Size (C_Name'Address)); + end if; + end Size; + + function Size (Directory_Entry : Directory_Entry_Type) return File_Size is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error; + + else + -- The value to return has already be computed + + return Size (To_String (Directory_Entry.Full)); + end if; + end Size; + + ------------------ + -- Start_Search -- + ------------------ + + procedure Start_Search + (Search : in out Search_Type; + Directory : String; + Pattern : String; + Filter : Filter_Type := (others => True)) + is + begin + -- First, the invalid case + + if not Is_Directory (Directory) then + raise Name_Error; + end if; + + -- If needed, finalize Search + + Finalize (Search); + + -- Allocate the default data + + Search.Value := new Search_Data; + + begin + -- Check the pattern + + Search.Value.Pattern := Compile (Pattern, Glob => True); + + exception + when Error_In_Regexp => + Free (Search.Value); + raise Name_Error; + end; + + -- Initialize some Search components + + Search.Value.Filter := Filter; + Search.Value.Name := To_Unbounded_String (Full_Name (Directory)); + Open (Search.Value.Dir, Directory); + Search.Value.Is_Valid := True; + end Start_Search; + + ---------------------------------- + -- To_Lower_If_Case_Insensitive -- + ---------------------------------- + + procedure To_Lower_If_Case_Insensitive (S : in out String) is + begin + if not Is_Path_Name_Case_Sensitive then + for J in S'Range loop + S (J) := To_Lower (S (J)); + end loop; + end if; + end To_Lower_If_Case_Insensitive; + +end Ada.Directories; |