Implement a missing portion of Ada 2005's AI05-0049-1 for subprogram
Ada.Directories.Name_Case_Equivalence so that user programs can account for
operating system differences in case sensitivity.
------------
-- Source --
------------
-- main.adb
with Ada.Directories; use Ada.Directories;
with Ada.Text_IO; use Ada.Text_IO;
procedure Main is
begin
-- Directory layout:
-- /empty +-- Nothing...
--
-- /mutliplefiles +-- "TEST1.TXT"
-- |
-- "test1.txt"
--
-- /singlefile +-- "test1.txt"
--
-- /noncasable +-- "!"
--
Put_Line (Name_Case_Equivalence ("./empty")'Image);
Put_Line (Name_Case_Equivalence ("./multiplefiles")'Image);
Put_Line (Name_Case_Equivalence ("./singlefile")'Image);
Put_Line (Name_Case_Equivalence ("./multiplefiles/test1.txt")'Image);
Put_Line (Name_Case_Equivalence ("./singlefile/test1.txt")'Image);
Put_Line (Name_Case_Equivalence ("./noncaseable/!")'Image);
end;
----------------------------
-- Compilation and Output --
----------------------------
& gnatmake -q main.adb
& main
CASE_SENSITIVE
CASE_SENSITIVE
CASE_SENSITIVE
CASE_SENSITIVE
CASE_SENSITIVE
CASE_SENSITIVE
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-05-30 Justin Squirek <squi...@adacore.com>
gcc/ada/
* libgnat/a-direct.adb, libgnat/a-direct.ads (Name_Case_Equivalence):
Add implementation.
(Start_Search): Modify to use Start_Search_Internal
(Start_Search_Internal): Add to break out an extra flag for searching
case insensative due to the potential for directories within the same
OS to allow different casing schemes.
* sysdep.c (__gnat_name_case_equivalence): Add as a default fallback
for when the more precise solution fails.--- gcc/ada/libgnat/a-direct.adb
+++ gcc/ada/libgnat/a-direct.adb
@@ -38,6 +38,8 @@ with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;
+with Interfaces.C;
+
with System; use System;
with System.CRTL; use System.CRTL;
with System.File_Attributes; use System.File_Attributes;
@@ -91,6 +93,16 @@ package body Ada.Directories is
-- Get the next entry in a directory, setting Entry_Fetched if successful
-- or resetting Is_Valid if not.
+ procedure Start_Search_Internal
+ (Search : in out Search_Type;
+ Directory : String;
+ Pattern : String;
+ Filter : Filter_Type := (others => True);
+ Force_Case_Insensitive : Boolean);
+ -- Similar to Start_Search except we can force a search to be
+ -- case-insensitive, which is important for detecting the name-case
+ -- equivalence for a given directory.
+
---------------
-- Base_Name --
---------------
@@ -1057,6 +1069,103 @@ package body Ada.Directories is
return Search.Value.Is_Valid;
end More_Entries;
+ ---------------------------
+ -- Name_Case_Equivalence --
+ ---------------------------
+
+ function Name_Case_Equivalence (Name : String) return Name_Case_Kind is
+ Dir_Path : Unbounded_String := To_Unbounded_String (Name);
+ S : Search_Type;
+ Test_File : Directory_Entry_Type;
+
+ function GNAT_name_case_equivalence return Interfaces.C.int;
+ pragma Import
+ (C, GNAT_name_case_equivalence, "__gnat_name_case_equivalence");
+
+ begin
+ -- Check for the invalid case
+
+ if not Is_Valid_Path_Name (Name) then
+ raise Name_Error with "invalid path name """ & Name & '"';
+ end if;
+
+ -- We were passed a "full path" to a file and not a directory, so obtain
+ -- the containing directory.
+
+ if Is_Regular_File (Name) then
+ Dir_Path := To_Unbounded_String (Containing_Directory (Name));
+ end if;
+
+ -- Since we must obtain a file within the Name directory, let's grab the
+ -- first for our test. When the directory is empty, Get_Next_Entry will
+ -- fall through to a Status_Error where we then take the imprecise
+ -- default for the host OS.
+
+ Start_Search (Search => S,
+ Directory => To_String (Dir_Path),
+ Pattern => "",
+ Filter => (Directory => False, others => True));
+
+ loop
+ Get_Next_Entry (S, Test_File);
+
+ -- Check if we have found a "caseable" file
+
+ exit when To_Lower (Simple_Name (Test_File)) /=
+ To_Upper (Simple_Name (Test_File));
+ end loop;
+
+ End_Search (S);
+
+ -- Search for files within the directory with the same name, but
+ -- differing cases.
+
+ Start_Search_Internal
+ (Search => S,
+ Directory => To_String (Dir_Path),
+ Pattern => Simple_Name (Test_File),
+ Filter => (Directory => False, others => True),
+ Force_Case_Insensitive => True);
+
+ -- We will find at least one match due to the search hitting our test
+ -- file.
+
+ Get_Next_Entry (S, Test_File);
+
+ begin
+ -- If we hit two then we know we have a case-sensitive directory
+
+ Get_Next_Entry (S, Test_File);
+ End_Search (S);
+
+ return Case_Sensitive;
+ exception
+ when Status_Error =>
+ null;
+ end;
+
+ -- Finally, we have a file in the directory whose name is unique and
+ -- "caseable". Let's test to see if the OS is able to identify the file
+ -- in multiple cases, which will give us our result without having to
+ -- resort to defaults.
+
+ if Exists (To_String (Dir_Path) & Directory_Separator
+ & To_Lower (Simple_Name (Test_File)))
+ and then Exists (To_String (Dir_Path) & Directory_Separator
+ & To_Upper (Simple_Name (Test_File)))
+ then
+ return Case_Preserving;
+ end if;
+
+ return Case_Sensitive;
+ exception
+ when Status_Error =>
+ -- There is no unobtrusive way to check for the directory's casing so
+ -- return the OS default.
+
+ return Name_Case_Kind'Val (Integer (GNAT_name_case_equivalence));
+ end Name_Case_Equivalence;
+
------------
-- Rename --
------------
@@ -1289,6 +1398,21 @@ package body Ada.Directories is
Pattern : String;
Filter : Filter_Type := (others => True))
is
+ begin
+ Start_Search_Internal (Search, Directory, Pattern, Filter, False);
+ end Start_Search;
+
+ ---------------------------
+ -- Start_Search_Internal --
+ ---------------------------
+
+ procedure Start_Search_Internal
+ (Search : in out Search_Type;
+ Directory : String;
+ Pattern : String;
+ Filter : Filter_Type := (others => True);
+ Force_Case_Insensitive : Boolean)
+ is
function opendir (file_name : String) return DIRs;
pragma Import (C, opendir, "__gnat_opendir");
@@ -1306,11 +1430,17 @@ package body Ada.Directories is
-- Check the pattern
+ declare
+ Case_Sensitive : Boolean := Is_Path_Name_Case_Sensitive;
begin
+ if Force_Case_Insensitive then
+ Case_Sensitive := False;
+ end if;
+
Pat := Compile
(Pattern,
Glob => True,
- Case_Sensitive => Is_Path_Name_Case_Sensitive);
+ Case_Sensitive => Case_Sensitive);
exception
when Error_In_Regexp =>
Free (Search.Value);
@@ -1339,6 +1469,6 @@ package body Ada.Directories is
Search.Value.Pattern := Pat;
Search.Value.Dir := Dir;
Search.Value.Is_Valid := True;
- end Start_Search;
+ end Start_Search_Internal;
end Ada.Directories;
--- gcc/ada/libgnat/a-direct.ads
+++ gcc/ada/libgnat/a-direct.ads
@@ -231,6 +231,11 @@ package Ada.Directories is
-- File and directory name operations --
----------------------------------------
+ type Name_Case_Kind is
+ (Unknown, Case_Sensitive, Case_Insensitive, Case_Preserving);
+ -- The type Name_Case_Kind represents the kind of file-name equivalence
+ -- rule for directories.
+
function Full_Name (Name : String) return String;
-- Returns the full name corresponding to the file name specified by Name.
-- The exception Name_Error is propagated if the string given as Name does
@@ -281,6 +286,16 @@ package Ada.Directories is
-- Name is not a possible simple name (if Extension is null) or base name
-- (if Extension is non-null).
+ function Name_Case_Equivalence (Name : String) return Name_Case_Kind;
+ -- Returns the file-name equivalence rule for the directory containing
+ -- Name. Raises Name_Error if Name is not a full name. Returns
+ -- Case_Sensitive if file names that differ only in the case of letters are
+ -- considered different names. If file names that differ only in the case
+ -- of letters are considered the same name, then Case_Preserving is
+ -- returned if names have the case of the file name used when a file is
+ -- created; and Case_Insensitive is returned otherwise. Returns Unknown if
+ -- the file-name equivalence is not known.
+
--------------------------------
-- File and directory queries --
--------------------------------
--- gcc/ada/sysdep.c
+++ gcc/ada/sysdep.c
@@ -1049,3 +1049,21 @@ _getpagesize (void)
return getpagesize ();
}
#endif
+
+int
+__gnat_name_case_equivalence ()
+{
+ /* the values here must be synchronized with Ada.Directories.Name_Case_Kind:
+
+ Unknown = 0
+ Case_Sensitive = 1
+ Case_Insensitive = 2
+ Case_Preserving = 3 */
+
+#if defined (__APPLE__) || defined (WIN32)
+ return 3;
+#else
+ return 1;
+#endif
+}
+
