-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2007, 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. --
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_Value := No_Dir;
-- 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.
if Containing_Directory /= ""
and then not Is_Valid_Path_Name (Containing_Directory)
then
- raise Name_Error;
+ 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)
then
- raise Name_Error;
+ raise Name_Error with
+ "invalid file name """ & Name & '.' & Extension & '"';
-- This is not an invalid case so build the path name
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
declare
and then (Norm (Norm'First) in 'a' .. 'z'
or else Norm (Norm'First) in 'A' .. 'Z'))))
then
- raise Use_Error;
+ raise Use_Error with
+ "directory """ & Name & """ has no containing directory";
else
declare
return Containing_Directory (Current_Directory);
else
- To_Lower_If_Case_Insensitive (Result (1 .. Last));
return Result (1 .. Last);
end if;
end;
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 System.OS_Lib.Copy_File, with parameters
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;
-- 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
if mkdir (C_Dir_Name) /= 0 then
- raise Use_Error;
+ 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
-- 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
Create_Directory (New_Directory => New_Dir (1 .. Last));
Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
declare
- Cur : String := Normalize_Pathname (Buffer (1 .. Path_Len));
+ Cur : constant String := Normalize_Pathname (Buffer (1 .. Path_Len));
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
-- 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
declare
C_Dir_Name : constant String := Directory & ASCII.NUL;
- begin
- rmdir (C_Dir_Name);
- if System.OS_Lib.Is_Directory (Directory) then
- raise Use_Error;
+ begin
+ if rmdir (C_Dir_Name) /= 0 then
+ raise Use_Error with
+ "deletion of directory """ & Directory & """ failed";
end if;
end;
end if;
-- 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 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;
-- 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
Set_Directory (Directory);
C_Dir_Name : constant String := Directory & ASCII.NUL;
begin
- rmdir (C_Dir_Name);
-
- if System.OS_Lib.Is_Directory (Directory) then
- raise Use_Error;
+ 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;
-- 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
-- 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 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_Fetched and return the 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 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;
procedure Set_Directory (Directory : String) is
C_Dir_Name : constant String := Directory & ASCII.NUL;
+ begin
+ if not Is_Valid_Path_Name (Directory) then
+ raise Name_Error with
+ "invalid directory path name & """ & Directory & '"';
- function chdir (Dir_Name : String) return Integer;
- pragma Import (C, chdir, "chdir");
+ elsif not Is_Directory (Directory) then
+ raise Name_Error with
+ "directory """ & Directory & """ does not exist";
- begin
- if chdir (C_Dir_Name) /= 0 then
- 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_CI (Path : String) return String;
- -- This function does the job. The difference between Simple_Name_CI
- -- and Simple_Name (the parent function) is that the former is case
- -- sensitive, while the latter is not. Path and Suffix are adjusted
- -- appropriately before calling Simple_Name_CI under platforms where
- -- the file system is not case sensitive.
+ function Simple_Name_Internal (Path : String) return String;
+ -- This function does the job
- --------------------
- -- Simple_Name_CI --
- --------------------
+ --------------------------
+ -- Simple_Name_Internal --
+ --------------------------
- function Simple_Name_CI (Path : String) return String is
+ function Simple_Name_Internal (Path : String) return String is
Cut_Start : Natural :=
Strings.Fixed.Index
(Path, Dir_Seps, Going => Strings.Backward);
Cut_End := Path'Last;
Check_For_Standard_Dirs : declare
- Offset : constant Integer := Path'First - Name'First;
- BN : constant String :=
- Name (Cut_Start - Offset .. Cut_End - Offset);
- -- Here we use Simple_Name.Name to keep the original casing
-
+ 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
return BN;
end if;
end Check_For_Standard_Dirs;
- end Simple_Name_CI;
+ end Simple_Name_Internal;
-- Start of processing for Simple_Name
-- 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
- if Is_Path_Name_Case_Sensitive then
- declare
- Value : constant String := Simple_Name_CI (Name);
- subtype Result is String (1 .. Value'Length);
- begin
- return Result (Value);
- end;
-
- else
- declare
- Value : constant String :=
- Simple_Name_CI (Characters.Handling.To_Lower (Name));
- subtype Result is String (1 .. Value'Length);
- begin
- return Result (Value);
- end;
- end if;
+ declare
+ Value : constant String := Simple_Name_Internal (Name);
+ subtype Result is String (1 .. Value'Length);
+ begin
+ 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
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));
- Search.Value.Dir := Dir_Type_Value (opendir (C_File_Name));
+ 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
