-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2009, 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- --
+-- ware Foundation; either version 3, 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. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- 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. --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Ada.Calendar; use Ada.Calendar;
with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;
with Ada.Directories.Validity; use Ada.Directories.Validity;
+with Ada.Strings.Maps;
+with Ada.Strings.Fixed;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
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.CRTL; use System.CRTL;
+with System.OS_Lib; use System.OS_Lib;
+with System.Regexp; use System.Regexp;
with System;
package body Ada.Directories is
+ Filename_Max : constant Integer := 1024;
+ -- 1024 is the value of FILENAME_MAX in stdio.h
+
+ type Dir_Type_Value is new System.Address;
+ -- This is the low-level address directory structure as returned by the C
+ -- opendir routine.
+
+ No_Dir : constant Dir_Type_Value := Dir_Type_Value (System.Null_Address);
+
+ Dir_Separator : constant Character;
+ pragma Import (C, Dir_Separator, "__gnat_dir_separator");
+ -- Running system default directory separator
+
+ Dir_Seps : constant Ada.Strings.Maps.Character_Set :=
+ Ada.Strings.Maps.To_Set ("/\");
+ -- UNIX and DOS style directory separators
+
+ Max_Path : Integer;
+ pragma Import (C, Max_Path, "__gnat_max_path_len");
+ -- The maximum length of a path
+
type Search_Data is record
Is_Valid : Boolean := False;
- Name : Ada.Strings.Unbounded.Unbounded_String;
+ Name : Unbounded_String;
Pattern : Regexp;
Filter : Filter_Type;
- Dir : Dir_Type;
+ Dir : Dir_Type_Value := No_Dir;
Entry_Fetched : Boolean := False;
Dir_Entry : Directory_Entry_Type;
end record;
procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
+ procedure Close (Dir : Dir_Type_Value);
+
function File_Exists (Name : String) return Boolean;
-- Returns True if the named file exists
-- 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 : constant 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.
return Simple;
end Base_Name;
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (Dir : Dir_Type_Value) is
+ Discard : Integer;
+ pragma Warnings (Off, Discard);
+
+ function closedir (directory : DIRs) return Integer;
+ pragma Import (C, closedir, "__gnat_closedir");
+
+ begin
+ Discard := closedir (DIRs (Dir));
+ end Close;
+
-------------
-- Compose --
-------------
begin
-- First, deal with the invalid cases
- if not Is_Valid_Path_Name (Containing_Directory) then
- raise Name_Error;
+ if Containing_Directory /= ""
+ and then not Is_Valid_Path_Name (Containing_Directory)
+ then
+ raise Name_Error with
+ "invalid directory path name """ & Containing_Directory & '"';
elsif
Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
then
- raise Name_Error;
+ raise Name_Error with
+ "invalid simple name """ & Name & '"';
- elsif Extension'Length /= 0 and then
- (not Is_Valid_Simple_Name (Name & '.' & Extension))
+ elsif Extension'Length /= 0
+ and then not Is_Valid_Simple_Name (Name & '.' & Extension)
then
- raise Name_Error;
+ raise Name_Error with
+ "invalid file name """ & Name & '.' & Extension & '"';
- -- This is not an invalid case so build the path name
+ -- This is not an invalid case so build the path name
else
Last := Containing_Directory'Length;
-- Add a directory separator if needed
- if Result (Last) /= Dir_Separator then
+ if Last /= 0 and then Result (Last) /= Dir_Separator then
Last := Last + 1;
Result (Last) := Dir_Separator;
end if;
Last := Last + Extension'Length;
end if;
- To_Lower_If_Case_Insensitive (Result (1 .. Last));
return Result (1 .. Last);
end if;
end Compose;
-- First, the invalid case
if not Is_Valid_Path_Name (Name) then
- raise Name_Error;
+ raise Name_Error with "invalid path name """ & Name & '"';
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;
+ Norm : constant String := Normalize_Pathname (Name);
+ Last_DS : constant Natural :=
+ Strings.Fixed.Index
+ (Name, Dir_Seps, Going => Strings.Backward);
begin
- Result := Value;
+ if Last_DS = 0 then
+
+ -- There is no directory separator, returns current working
+ -- directory.
+
+ return Current_Directory;
+
+ -- If Name indicates a root directory, raise Use_Error, because
+ -- it has no containing directory.
+
+ elsif Norm = "/"
+ or else
+ (Windows
+ and then
+ (Norm = "\"
+ or else
+ (Norm'Length = 3
+ and then Norm (Norm'Last - 1 .. Norm'Last) = ":\"
+ and then (Norm (Norm'First) in 'a' .. 'z'
+ or else Norm (Norm'First) in 'A' .. 'Z'))))
+ then
+ raise Use_Error with
+ "directory """ & Name & """ has no containing directory";
- -- Remove any trailing directory separator, except as the first
- -- character.
+ else
+ declare
+ Last : Positive := Last_DS - Name'First + 1;
+ Result : String (1 .. Last);
- while Last > 1 and then Result (Last) = Dir_Separator loop
- Last := Last - 1;
- end loop;
+ begin
+ Result := Name (Name'First .. Last_DS);
- -- Special case of current directory, identified by "."
+ -- Remove any trailing directory separator, except as the
+ -- first character or the first character following a drive
+ -- number on Windows.
- if Last = 1 and then Result (1) = '.' then
- return Get_Current_Dir;
+ while Last > 1 loop
+ exit when
+ Result (Last) /= '/'
+ and then
+ Result (Last) /= Directory_Separator;
- else
- To_Lower_If_Case_Insensitive (Result (1 .. Last));
- return Result (1 .. Last);
+ exit when Windows
+ and then Last = 3
+ and then Result (2) = ':'
+ and then
+ (Result (1) in 'A' .. 'Z'
+ or else
+ Result (1) in 'a' .. 'z');
+
+ Last := Last - 1;
+ end loop;
+
+ -- Special case of current directory, identified by "."
+
+ if Last = 1 and then Result (1) = '.' then
+ return Current_Directory;
+
+ -- Special case of "..": the current directory may be a root
+ -- directory.
+
+ elsif Last = 2 and then Result (1 .. 2) = ".." then
+ return Containing_Directory (Current_Directory);
+
+ else
+ return Result (1 .. Last);
+ end if;
+ end;
end if;
end;
end if;
---------------
procedure Copy_File
- (Source_Name : String;
- Target_Name : String;
- Form : String := "")
+ (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;
+ if not Is_Valid_Path_Name (Source_Name) then
+ raise Name_Error with
+ "invalid source path name """ & Source_Name & '"';
+
+ elsif not Is_Valid_Path_Name (Target_Name) then
+ raise Name_Error with
+ "invalid target path name """ & Target_Name & '"';
+
+ elsif not Is_Regular_File (Source_Name) then
+ raise Name_Error with '"' & Source_Name & """ is not a file";
elsif Is_Directory (Target_Name) then
- raise Use_Error;
+ raise Use_Error with "target """ & Target_Name & """ is a directory";
else
- -- The implementation uses GNAT.OS_Lib.Copy_File, with parameters
+ -- The implementation uses System.OS_Lib.Copy_File, with parameters
-- suitable for all platforms.
- Copy_File
- (Source_Name, Target_Name, Success, Overwrite, None);
+ Copy_File (Source_Name, Target_Name, Success, Overwrite, None);
if not Success then
- raise Use_Error;
+ raise Use_Error with "copy of """ & Source_Name & """ failed";
end if;
end if;
end Copy_File;
is
pragma Unreferenced (Form);
+ C_Dir_Name : constant String := New_Directory & ASCII.NUL;
+
+ function mkdir (Dir_Name : String) return Integer;
+ pragma Import (C, mkdir, "__gnat_mkdir");
+
begin
-- First, the invalid case
if not Is_Valid_Path_Name (New_Directory) then
- raise Name_Error;
+ raise Name_Error with
+ "invalid new directory path name """ & New_Directory & '"';
else
- -- The implementation uses GNAT.Directory_Operations.Make_Dir
-
- begin
- Make_Dir (Dir_Name => New_Directory);
-
- exception
- when Directory_Error =>
- raise Use_Error;
- end;
+ if mkdir (C_Dir_Name) /= 0 then
+ raise Use_Error with
+ "creation of new directory """ & New_Directory & """ failed";
+ end if;
end if;
end Create_Directory;
-- First, the invalid case
if not Is_Valid_Path_Name (New_Directory) then
- raise Name_Error;
+ raise Name_Error with
+ "invalid new directory path name """ & New_Directory & '"';
else
-- Build New_Dir with a directory separator at the end, so that the
-- Look for the end of an intermediate directory
- if New_Dir (J) /= Dir_Separator then
+ if New_Dir (J) /= Dir_Separator and then
+ New_Dir (J) /= '/'
+ 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
+ elsif New_Dir (J - 1) /= Dir_Separator and then
+ New_Dir (J - 1) /= '/'
+ then
-- No need to create the directory if it already exists
-- 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;
+ raise Use_Error with
+ "file """ & New_Dir (1 .. Last) & """ already exists";
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;
+ Create_Directory (New_Directory => New_Dir (1 .. Last));
end if;
end if;
end loop;
-----------------------
function Current_Directory return String is
+ Path_Len : Natural := Max_Path;
+ Buffer : String (1 .. 1 + Max_Path + 1);
- -- The implementation uses GNAT.Directory_Operations.Get_Current_Dir
-
- Cur : String := Normalize_Pathname (Get_Current_Dir);
+ procedure Local_Get_Current_Dir
+ (Dir : System.Address;
+ Length : System.Address);
+ pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
begin
- To_Lower_If_Case_Insensitive (Cur);
+ Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
- if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
- return Cur (1 .. Cur'Last - 1);
- else
- return Cur;
- end if;
+ declare
+ Cur : constant String := Normalize_Pathname (Buffer (1 .. Path_Len));
+
+ begin
+ if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
+ return Cur (1 .. Cur'Last - 1);
+ else
+ return Cur;
+ end if;
+ end;
end Current_Directory;
----------------------
-- First, the invalid cases
if not Is_Valid_Path_Name (Directory) then
- raise Name_Error;
+ raise Name_Error with
+ "invalid directory path name """ & Directory & '"';
elsif not Is_Directory (Directory) then
- raise Name_Error;
+ raise Name_Error with '"' & Directory & """ not a directory";
else
- -- The implementation uses GNAT.Directory_Operations.Remove_Dir
+ declare
+ C_Dir_Name : constant String := Directory & ASCII.NUL;
begin
- Remove_Dir (Dir_Name => Directory, Recursive => False);
-
- exception
- when Directory_Error =>
- raise Use_Error;
+ if rmdir (C_Dir_Name) /= 0 then
+ raise Use_Error with
+ "deletion of directory """ & Directory & """ failed";
+ end if;
end;
end if;
end Delete_Directory;
-- First, the invalid cases
if not Is_Valid_Path_Name (Name) then
- raise Name_Error;
+ raise Name_Error with "invalid path name """ & Name & '"';
elsif not Is_Regular_File (Name) then
- raise Name_Error;
+ raise Name_Error with "file """ & Name & """ does not exist";
else
- -- The implementation uses GNAT.OS_Lib.Delete_File
+ -- The implementation uses System.OS_Lib.Delete_File
Delete_File (Name, Success);
if not Success then
- raise Use_Error;
+ raise Use_Error with "file """ & Name & """ could not be deleted";
end if;
end if;
end Delete_File;
-----------------
procedure Delete_Tree (Directory : String) is
+ Current_Dir : constant String := Current_Directory;
+ Search : Search_Type;
+ Dir_Ent : Directory_Entry_Type;
begin
-- First, the invalid cases
if not Is_Valid_Path_Name (Directory) then
- raise Name_Error;
+ raise Name_Error with
+ "invalid directory path name """ & Directory & '"';
elsif not Is_Directory (Directory) then
- raise Name_Error;
+ raise Name_Error with '"' & Directory & """ not a directory";
else
- -- The implementation uses GNAT.Directory_Operations.Remove_Dir
+ Set_Directory (Directory);
+ Start_Search (Search, Directory => ".", Pattern => "");
- begin
- Remove_Dir (Directory, Recursive => True);
+ while More_Entries (Search) loop
+ Get_Next_Entry (Search, Dir_Ent);
+
+ declare
+ File_Name : constant String := Simple_Name (Dir_Ent);
- exception
- when Directory_Error =>
- raise Use_Error;
+ begin
+ if System.OS_Lib.Is_Directory (File_Name) then
+ if File_Name /= "." and then File_Name /= ".." then
+ Delete_Tree (File_Name);
+ end if;
+
+ else
+ Delete_File (File_Name);
+ end if;
+ end;
+ end loop;
+
+ Set_Directory (Current_Dir);
+ End_Search (Search);
+
+ declare
+ C_Dir_Name : constant String := Directory & ASCII.NUL;
+
+ begin
+ if rmdir (C_Dir_Name) /= 0 then
+ raise Use_Error with
+ "directory tree rooted at """ &
+ Directory & """ could not be deleted";
+ end if;
end;
end if;
end Delete_Tree;
-- First, the invalid case
if not Is_Valid_Path_Name (Name) then
- raise Name_Error;
+ raise Name_Error with "invalid path name """ & Name & '"';
else
-- The implementation is in File_Exists
-- First, the invalid case
if not Is_Valid_Path_Name (Name) then
- raise Name_Error;
+ raise Name_Error with "invalid path name """ & Name & '"';
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 a directory separator is found before a dot, there is no
+ -- extension.
if Name (Pos) = Dir_Separator then
return Empty_String;
-- We found a dot, build the return value with lower bound 1
declare
- Result : String (1 .. Name'Last - Pos);
+ subtype Result_Type is 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 ???
+ return Result_Type (Name (Pos + 1 .. Name'Last));
end;
end if;
end loop;
Kind : File_Kind := Ordinary_File;
-- Initialized to avoid a compilation warning
+ Filename_Addr : System.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");
+
+ use System;
+
begin
-- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
loop
- Read (Search.Value.Dir, Name, Last);
+ Filename_Addr :=
+ readdir_gnat
+ (System.Address (Search.Value.Dir),
+ Buffer'Address,
+ Filename_Len'Access);
-- If no matching entry is found, set Is_Valid to False
- if Last = 0 then
+ if Filename_Addr = System.Null_Address then
Search.Value.Is_Valid := False;
exit;
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
+ Ada.Unchecked_Conversion
+ (Source => Address,
+ Target => Path_String_Access);
+
+ Path_Access : constant Path_String_Access :=
+ Address_To_Access (Filename_Addr);
+
+ begin
+ Last := Filename_Len;
+ Name (1 .. Last) := Path_Access.all;
+ end;
+
-- Check if the entry matches the pattern
if Match (Name (1 .. Last), Search.Value.Pattern) then
-- Close the directory, if one is open
- if Is_Open (Search.Value.Dir) then
+ if Search.Value.Dir /= No_Dir then
Close (Search.Value.Dir);
end if;
-- First, the invalid case
if not Is_Valid_Path_Name (Name) then
- raise Name_Error;
+ raise Name_Error with "invalid path name """ & Name & '"';
else
-- Build the return value with lower bound 1
- -- Use GNAT.OS_Lib.Normalize_Pathname
+ -- Use System.OS_Lib.Normalize_Pathname
declare
- Value : String := Normalize_Pathname (Name);
+ Value : constant String := Normalize_Pathname (Name);
subtype Result is String (1 .. Value'Length);
begin
- To_Lower_If_Case_Insensitive (Value);
return Result (Value);
end;
end if;
-- First, the invalid case
if not Directory_Entry.Is_Valid then
- raise Status_Error;
+ raise Status_Error with "invalid directory entry";
else
-- The value to return has already been computed
-- First, the invalid case
if Search.Value = null or else not Search.Value.Is_Valid then
- raise Status_Error;
+ raise Status_Error with "invalid search";
end if;
-- Fetch the next entry, if needed
-- It is an error if no valid entry is found
if not Search.Value.Is_Valid then
- raise Status_Error;
+ raise Status_Error with "no next entry";
else
- -- Reset Entry_Fatched and return the entry
+ -- Reset Entry_Fetched and return the entry
Search.Value.Entry_Fetched := False;
Directory_Entry := Search.Value.Dir_Entry;
-- First, the invalid case
if not File_Exists (Name) then
- raise Name_Error;
+ raise Name_Error with "file """ & Name & """ does not exist";
elsif Is_Regular_File (Name) then
return Ordinary_File;
-- First, the invalid case
if not Directory_Entry.Is_Valid then
- raise Status_Error;
+ raise Status_Error with "invalid directory entry";
else
-- The value to return has already be computed
-- First, the invalid cases
if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
- raise Name_Error;
+ raise Name_Error with '"' & Name & """ not a file or directory";
else
Date := File_Time_Stamp (Name);
-- First, the invalid case
if not Directory_Entry.Is_Valid then
- raise Status_Error;
+ raise Status_Error with "invalid directory entry";
else
-- The value to return has already be computed
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))
+ if not Is_Valid_Path_Name (Old_Name) then
+ raise Name_Error with "invalid old path name """ & Old_Name & '"';
+
+ elsif not Is_Valid_Path_Name (New_Name) then
+ raise Name_Error with "invalid new path name """ & New_Name & '"';
+
+ elsif not Is_Regular_File (Old_Name)
+ and then not Is_Directory (Old_Name)
then
- raise Name_Error;
+ raise Name_Error with "old file """ & Old_Name & """ does not exist";
- elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then
- raise Use_Error;
+ elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then
+ raise Use_Error with
+ "new name """ & New_Name
+ & """ designates a file that already exists";
else
- -- The implementation uses GNAT.OS_Lib.Rename_File
+ -- The implementation uses System.OS_Lib.Rename_File
Rename_File (Old_Name, New_Name, Success);
if not Success then
- raise Use_Error;
+ raise Use_Error with
+ "file """ & Old_Name & """ could not be renamed";
end if;
end if;
end Rename;
Process : not null access procedure
(Directory_Entry : Directory_Entry_Type))
is
- Srch : Search_Type;
+ Srch : Search_Type;
Directory_Entry : Directory_Entry_Type;
+
begin
Start_Search (Srch, Directory, Pattern, Filter);
-------------------
procedure Set_Directory (Directory : String) is
+ C_Dir_Name : constant String := Directory & ASCII.NUL;
begin
- -- The implementation uses GNAT.Directory_Operations.Change_Dir
+ if not Is_Valid_Path_Name (Directory) then
+ raise Name_Error with
+ "invalid directory path name & """ & Directory & '"';
- Change_Dir (Dir_Name => Directory);
+ elsif not Is_Directory (Directory) then
+ raise Name_Error with
+ "directory """ & Directory & """ does not exist";
- exception
- when Directory_Error =>
- raise Name_Error;
+ elsif chdir (C_Dir_Name) /= 0 then
+ raise Name_Error with
+ "could not set to designated directory """ & Directory & '"';
+ end if;
end Set_Directory;
-----------------
-----------------
function Simple_Name (Name : String) return String is
+
+ function Simple_Name_Internal (Path : String) return String;
+ -- This function does the job
+
+ --------------------------
+ -- Simple_Name_Internal --
+ --------------------------
+
+ function Simple_Name_Internal (Path : 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 simple name character
+
+ if Cut_Start = 0 then
+ Cut_Start := Path'First;
+
+ else
+ Cut_Start := Cut_Start + 1;
+ end if;
+
+ -- Cut_End point to the last simple name character
+
+ Cut_End := Path'Last;
+
+ Check_For_Standard_Dirs : declare
+ BN : constant String := Path (Cut_Start .. Cut_End);
+ Has_Drive_Letter : constant Boolean :=
+ System.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 Simple_Name_Internal;
+
+ -- Start of processing for Simple_Name
+
begin
-- First, the invalid case
if not Is_Valid_Path_Name (Name) then
- raise Name_Error;
+ raise Name_Error with "invalid path name """ & Name & '"';
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);
+ Value : constant String := Simple_Name_Internal (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
+ (Directory_Entry : Directory_Entry_Type) return String is
begin
-- First, the invalid case
if not Directory_Entry.Is_Valid then
- raise Status_Error;
+ raise Status_Error with "invalid directory entry";
else
-- The value to return has already be computed
-- First, the invalid case
if not Is_Regular_File (Name) then
- raise Name_Error;
+ raise Name_Error with "file """ & Name & """ does not exist";
else
C_Name (1 .. Name'Length) := Name;
-- First, the invalid case
if not Directory_Entry.Is_Valid then
- raise Status_Error;
+ raise Status_Error with "invalid directory entry";
else
-- The value to return has already be computed
Pattern : String;
Filter : Filter_Type := (others => True))
is
+ function opendir (file_name : String) return DIRs;
+ pragma Import (C, opendir, "__gnat_opendir");
+
+ C_File_Name : constant String := Directory & ASCII.NUL;
+ Pat : Regexp;
+ Dir : Dir_Type_Value;
+
begin
- -- First, the invalid case
+ -- First, the invalid case Name_Error
if not Is_Directory (Directory) then
- raise Name_Error;
+ raise Name_Error with
+ "unknown directory """ & Simple_Name (Directory) & '"';
+ end if;
+
+ -- Check the pattern
+
+ begin
+ Pat := Compile
+ (Pattern,
+ Glob => True,
+ Case_Sensitive => Is_Path_Name_Case_Sensitive);
+ exception
+ when Error_In_Regexp =>
+ Free (Search.Value);
+ raise Name_Error with "invalid pattern """ & Pattern & '"';
+ end;
+
+ Dir := Dir_Type_Value (opendir (C_File_Name));
+
+ if Dir = No_Dir then
+ raise Use_Error with
+ "unreadable directory """ & Simple_Name (Directory) & '"';
end if;
-- If needed, finalize Search
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.Filter := Filter;
+ Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
+ Search.Value.Pattern := Pat;
+ Search.Value.Dir := Dir;
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;
OSDN Git Service
