gcc/ada/libgnat/a-dhfina.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                  ADA.DIRECTORIES.HIERARCHICAL_FILE_NAMES                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2023, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- In particular,  you can freely  distribute your programs  built with the --
  23 -- GNAT Pro compiler, including any required library run-time units,  using --
  24 -- any licensing terms  of your choosing.  See the AdaCore Software License --
  25 -- for full details.                                                        --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Characters.Handling;  use Ada.Characters.Handling;
  33 with Ada.Directories.Validity; use Ada.Directories.Validity;
  34 with Ada.Strings.Fixed;        use Ada.Strings.Fixed;
  35 with System;                   use System;
  36
  37 package body Ada.Directories.Hierarchical_File_Names is
  38
  39    Dir_Separator : constant Character;
  40    pragma Import (C, Dir_Separator, "__gnat_dir_separator");
  41    --  Running system default directory separator
  42
  43    -----------------
  44    -- Subprograms --
  45    -----------------
  46
  47    function Equivalent_File_Names
  48      (Left  : String;
  49       Right : String)
  50       return Boolean;
  51    --  Perform an OS-independent comparison between two file paths
  52
  53    function Is_Absolute_Path (Name : String) return Boolean;
  54    --  Returns True if Name is an absolute path name, i.e. it designates a
  55    --  file or directory absolutely rather than relative to another directory.
  56
  57    ---------------------------
  58    -- Equivalent_File_Names --
  59    ---------------------------
  60
  61    function Equivalent_File_Names
  62      (Left  : String;
  63       Right : String)
  64       return Boolean
  65    is
  66    begin
  67       --  Check the validity of the input paths
  68
  69       if not Is_Valid_Path_Name (Left)
  70         or else not Is_Valid_Path_Name (Right)
  71       then
  72          return False;
  73       end if;
  74
  75       --  Normalize the paths by removing any trailing directory separators and
  76       --  perform the comparison.
  77
  78       declare
  79          Normal_Left  : constant String :=
  80            (if Index (Left, Dir_Separator & "", Strings.Backward) = Left'Last
  81               and then not Is_Root_Directory_Name (Left)
  82             then
  83                Left (Left'First .. Left'Last - 1)
  84             else
  85                Left);
  86
  87          Normal_Right : constant String :=
  88            (if Index (Right, Dir_Separator & "", Strings.Backward) = Right'Last
  89               and then not Is_Root_Directory_Name (Right)
  90             then
  91                Right (Right'First .. Right'Last - 1)
  92             else
  93                Right);
  94       begin
  95          --  Within Windows we assume case insensitivity
  96
  97          if not Windows then
  98             return Normal_Left = Normal_Right;
  99          end if;
 100
 101          --  Otherwise do a straight comparison
 102
 103          return To_Lower (Normal_Left) = To_Lower (Normal_Right);
 104       end;
 105    end Equivalent_File_Names;
 106
 107    ----------------------
 108    -- Is_Absolute_Path --
 109    ----------------------
 110
 111    function Is_Absolute_Path (Name : String) return Boolean is
 112       function Is_Absolute_Path
 113         (Name   : Address;
 114          Length : Integer) return Integer;
 115       pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
 116    begin
 117       return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
 118    end Is_Absolute_Path;
 119
 120    --------------------
 121    -- Is_Simple_Name --
 122    --------------------
 123
 124    function Is_Simple_Name (Name : String) return Boolean is
 125    begin
 126       --  Verify the file path name is valid and that it is not a root
 127
 128       if not Is_Valid_Path_Name (Name)
 129         or else Is_Root_Directory_Name (Name)
 130       then
 131          return False;
 132       end if;
 133
 134       --  Check for the special paths "." and "..", which are considered simple
 135
 136       if Is_Parent_Directory_Name (Name)
 137         or else Is_Current_Directory_Name (Name)
 138       then
 139          return True;
 140       end if;
 141
 142       --  Perform a comparison with the calculated simple path name
 143
 144       return Equivalent_File_Names (Simple_Name (Name), Name);
 145    end Is_Simple_Name;
 146
 147    ----------------------------
 148    -- Is_Root_Directory_Name --
 149    ----------------------------
 150
 151    function Is_Root_Directory_Name (Name : String) return Boolean is
 152    begin
 153       --  Check if the path name is a root directory by looking for a slash in
 154       --  the general case, and a drive letter in the case of Windows.
 155
 156       return Name = "/"
 157                or else
 158                  (Windows
 159                    and then
 160                      (Name = "\"
 161                        or else
 162                          (Name'Length = 3
 163                            and then Name (Name'Last - 1) = ':'
 164                            and then Name (Name'Last) in '/' | '\'
 165                            and then (Name (Name'First) in 'a' .. 'z'
 166                                       or else
 167                                         Name (Name'First) in 'A' .. 'Z'))
 168                        or else
 169                          (Name'Length = 2
 170                            and then Name (Name'Last) = ':'
 171                            and then (Name (Name'First) in 'a' .. 'z'
 172                                       or else
 173                                         Name (Name'First) in 'A' .. 'Z'))));
 174    end Is_Root_Directory_Name;
 175
 176    ------------------------------
 177    -- Is_Parent_Directory_Name --
 178    ------------------------------
 179
 180    function Is_Parent_Directory_Name (Name : String) return Boolean is
 181    begin
 182       return Name = "..";
 183    end Is_Parent_Directory_Name;
 184
 185    -------------------------------
 186    -- Is_Current_Directory_Name --
 187    -------------------------------
 188
 189    function Is_Current_Directory_Name (Name : String) return Boolean is
 190    begin
 191       return Name = ".";
 192    end Is_Current_Directory_Name;
 193
 194    ------------------
 195    -- Is_Full_Name --
 196    ------------------
 197
 198    function Is_Full_Name (Name : String) return Boolean is
 199    begin
 200       return Equivalent_File_Names (Full_Name (Name), Name);
 201    end Is_Full_Name;
 202
 203    ----------------------
 204    -- Is_Relative_Name --
 205    ----------------------
 206
 207    function Is_Relative_Name (Name : String) return Boolean is
 208    begin
 209       return not Is_Absolute_Path (Name)
 210                and then Is_Valid_Path_Name (Name);
 211    end Is_Relative_Name;
 212
 213    -----------------------
 214    -- Initial_Directory --
 215    -----------------------
 216
 217    function Initial_Directory (Name : String) return String is
 218       Start : constant Integer := Index (Name, Dir_Separator & "");
 219    begin
 220       --  Verify path name
 221
 222       if not Is_Valid_Path_Name (Name) then
 223          raise Name_Error with "invalid path name """ & Name & '"';
 224       end if;
 225
 226       --  When there is no starting directory separator or the path name is a
 227       --  root directory then the path name is already simple - so return it.
 228
 229       if Is_Root_Directory_Name (Name) or else Start = 0 then
 230          return Name;
 231       end if;
 232
 233       --  When the initial directory of the path name is a root directory then
 234       --  the starting directory separator is part of the result so we must
 235       --  return it in the slice.
 236
 237       if Is_Root_Directory_Name (Name (Name'First .. Start)) then
 238          return Name (Name'First .. Start);
 239       end if;
 240
 241       --  Otherwise we grab a slice up to the starting directory separator
 242
 243       return Name (Name'First .. Start - 1);
 244    end Initial_Directory;
 245
 246    -------------------
 247    -- Relative_Name --
 248    -------------------
 249
 250    function Relative_Name (Name : String) return String is
 251    begin
 252       --  We cannot derive a relative name if Name does not exist
 253
 254       if not Is_Relative_Name (Name)
 255         and then not Is_Valid_Path_Name (Name)
 256       then
 257          raise Name_Error with "invalid relative path name """ & Name & '"';
 258       end if;
 259
 260       --  Name only has a single part and thus cannot be made relative
 261
 262       if Is_Simple_Name (Name)
 263         or else Is_Root_Directory_Name (Name)
 264       then
 265          raise Name_Error with
 266            "relative path name """ & Name & """ is composed of a single part";
 267       end if;
 268
 269       --  Trim the input according to the initial directory and maintain proper
 270       --  directory separation due to the fact that root directories may
 271       --  contain separators.
 272
 273       declare
 274          Init_Dir : constant String := Initial_Directory (Name);
 275       begin
 276          if Init_Dir (Init_Dir'Last) = Dir_Separator then
 277             return Name (Name'First + Init_Dir'Length .. Name'Last);
 278          end if;
 279
 280          return Name (Name'First + Init_Dir'Length + 1 .. Name'Last);
 281       end;
 282    end Relative_Name;
 283
 284    -------------
 285    -- Compose --
 286    -------------
 287
 288    function Compose
 289      (Directory     : String := "";
 290       Relative_Name : String;
 291       Extension     : String := "") return String
 292    is
 293       --  Append a directory separator if none is present
 294
 295       Separated_Dir : constant String :=
 296         (if    Directory = "" then ""
 297          elsif Directory (Directory'Last) = Dir_Separator then Directory
 298          else  Directory & Dir_Separator);
 299    begin
 300       --  Check that relative name is valid
 301
 302       if not Is_Relative_Name (Relative_Name) then
 303          raise Name_Error with
 304            "invalid relative path name """ & Relative_Name & '"';
 305       end if;
 306
 307       --  Check that directory is valid
 308
 309       if Separated_Dir /= ""
 310         and then (not Is_Valid_Path_Name (Separated_Dir & Relative_Name))
 311       then
 312          raise Name_Error with
 313            "invalid path composition """ & Separated_Dir & Relative_Name & '"';
 314       end if;
 315
 316       --  Check that the extension is valid
 317
 318       if Extension /= ""
 319         and then not Is_Valid_Path_Name
 320                        (Separated_Dir & Relative_Name & Extension)
 321       then
 322          raise Name_Error with
 323            "invalid path composition """
 324              & Separated_Dir & Relative_Name & Extension & '"';
 325       end if;
 326
 327       --  Concatenate the result
 328
 329       return Separated_Dir & Relative_Name & Extension;
 330    end Compose;
 331
 332 end Ada.Directories.Hierarchical_File_Names;