From patchwork Wed May 30 09:00:33 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 922637 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-478740-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="TZo9Ry1T"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 40wl3C29gFz9s1w for ; Wed, 30 May 2018 19:02:15 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=ynCugFpl63rsPRqKjITo9sOOXam4wkJXl9KZ51PzKLwlGR4rlb 56DGrXDIkTwb3hW/8PV3GT00AjzD5Tokypfivvq5EgpU/QZRsUZG3OKDGpbVqq0h gAzoH3wTRF+Cn2rxMJeeO4nw7tAYokkj5AOuYrZ09qcD7pPcm6ZLgZY+0= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=pIDhI3Qxle1OKCwVcBLxCDOUdTg=; b=TZo9Ry1TRAXnpxQO7TYY G3aVw03nDVduy7MbHAzBRZPn8+BSkmcGagBe6rv+4jBtvJP/YPjaUD081zObbEkY 1HJ3Ck33mrAPQGF81S6FUJvzM4T+vKw2SdVEYgcqU8pMjsT5D6KMErThy8a6TY8G 3mjT8AeqyVjBNR26IcJqXg4= Received: (qmail 87923 invoked by alias); 30 May 2018 09:01:22 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 82338 invoked by uid 89); 30 May 2018 09:00:38 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.2 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=resort, Extension X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 30 May 2018 09:00:34 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 289E05604A; Wed, 30 May 2018 05:00:33 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id 7lqfpuezG8xN; Wed, 30 May 2018 05:00:33 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 16CEB117F48; Wed, 30 May 2018 05:00:33 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 13F9A78A; Wed, 30 May 2018 05:00:33 -0400 (EDT) Date: Wed, 30 May 2018 05:00:33 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Justin Squirek Subject: [Ada] ACATS 4.1G - CXAG003 - Name_Case_Equivalence doesn't exist Message-ID: <20180530090033.GA22572@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes 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 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 +} +