MatCat.OpenSource/8sa1-gcc
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
cb4af25a80
8sa1-gcc/gcc/ada/a-direct.adb
Vincent Celier 57d9e177cc a-direct.ads, [...] (Search): New procedure in Ada 2005 
2006-10-31  Vincent Celier  <celier@adacore.com>

	* a-direct.ads, a-direct.adb (Search): New procedure in Ada 2005

From-SVN: r118322
2006-10-31 19:12:50 +01:00

1014 lines
27 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- 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-2006, 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;
------------
-- Search --
------------
procedure Search
(Directory : String;
Pattern : String;
Filter : Filter_Type := (others => True);
Process : not null access procedure
(Directory_Entry : Directory_Entry_Type))
is
Srch : Search_Type;
Directory_Entry : Directory_Entry_Type;
begin
Start_Search (Srch, Directory, Pattern, Filter);
while More_Entries (Srch) loop
Get_Next_Entry (Srch, Directory_Entry);
Process (Directory_Entry);
end loop;
End_Search (Srch);
end Search;
-------------------
-- 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;
Reference in New Issue View Git Blame Copy Permalink