------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- -- ADA.DIRECTORIES.HIERARCHICAL_FILE_NAMES -- -- -- -- B o d y -- -- -- -- Copyright (C) 2004-2022, 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 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. -- -- -- -- 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. -- -- -- -- In particular, you can freely distribute your programs built with the -- -- GNAT Pro compiler, including any required library run-time units, using -- -- any licensing terms of your choosing. See the AdaCore Software License -- -- for full details. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Directories.Validity; use Ada.Directories.Validity; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with System; use System; package body Ada.Directories.Hierarchical_File_Names is Dir_Separator : constant Character; pragma Import (C, Dir_Separator, "__gnat_dir_separator"); -- Running system default directory separator ----------------- -- Subprograms -- ----------------- function Equivalent_File_Names (Left : String; Right : String) return Boolean; -- Perform an OS-independent comparison between two file paths function Is_Absolute_Path (Name : String) return Boolean; -- Returns True if Name is an absolute path name, i.e. it designates a -- file or directory absolutely rather than relative to another directory. --------------------------- -- Equivalent_File_Names -- --------------------------- function Equivalent_File_Names (Left : String; Right : String) return Boolean is begin -- Check the validity of the input paths if not Is_Valid_Path_Name (Left) or else not Is_Valid_Path_Name (Right) then return False; end if; -- Normalize the paths by removing any trailing directory separators and -- perform the comparison. declare Normal_Left : constant String := (if Index (Left, Dir_Separator & "", Strings.Backward) = Left'Last and then not Is_Root_Directory_Name (Left) then Left (Left'First .. Left'Last - 1) else Left); Normal_Right : constant String := (if Index (Right, Dir_Separator & "", Strings.Backward) = Right'Last and then not Is_Root_Directory_Name (Right) then Right (Right'First .. Right'Last - 1) else Right); begin -- Within Windows we assume case insensitivity if not Windows then return Normal_Left = Normal_Right; end if; -- Otherwise do a straight comparison return To_Lower (Normal_Left) = To_Lower (Normal_Right); end; end Equivalent_File_Names; ---------------------- -- Is_Absolute_Path -- ---------------------- function Is_Absolute_Path (Name : String) return Boolean is function Is_Absolute_Path (Name : Address; Length : Integer) return Integer; pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path"); begin return Is_Absolute_Path (Name'Address, Name'Length) /= 0; end Is_Absolute_Path; -------------------- -- Is_Simple_Name -- -------------------- function Is_Simple_Name (Name : String) return Boolean is begin -- Verify the file path name is valid and that it is not a root if not Is_Valid_Path_Name (Name) or else Is_Root_Directory_Name (Name) then return False; end if; -- Check for the special paths "." and "..", which are considered simple if Is_Parent_Directory_Name (Name) or else Is_Current_Directory_Name (Name) then return True; end if; -- Perform a comparison with the calculated simple path name return Equivalent_File_Names (Simple_Name (Name), Name); end Is_Simple_Name; ---------------------------- -- Is_Root_Directory_Name -- ---------------------------- function Is_Root_Directory_Name (Name : String) return Boolean is begin -- Check if the path name is a root directory by looking for a slash in -- the general case, and a drive letter in the case of Windows. return Name = "/" or else (Windows and then (Name = "\" or else (Name'Length = 3 and then Name (Name'Last - 1) = ':' and then Name (Name'Last) in '/' | '\' and then (Name (Name'First) in 'a' .. 'z' or else Name (Name'First) in 'A' .. 'Z')) or else (Name'Length = 2 and then Name (Name'Last) = ':' and then (Name (Name'First) in 'a' .. 'z' or else Name (Name'First) in 'A' .. 'Z')))); end Is_Root_Directory_Name; ------------------------------ -- Is_Parent_Directory_Name -- ------------------------------ function Is_Parent_Directory_Name (Name : String) return Boolean is begin return Name = ".."; end Is_Parent_Directory_Name; ------------------------------- -- Is_Current_Directory_Name -- ------------------------------- function Is_Current_Directory_Name (Name : String) return Boolean is begin return Name = "."; end Is_Current_Directory_Name; ------------------ -- Is_Full_Name -- ------------------ function Is_Full_Name (Name : String) return Boolean is begin return Equivalent_File_Names (Full_Name (Name), Name); end Is_Full_Name; ---------------------- -- Is_Relative_Name -- ---------------------- function Is_Relative_Name (Name : String) return Boolean is begin return not Is_Absolute_Path (Name) and then Is_Valid_Path_Name (Name); end Is_Relative_Name; ----------------------- -- Initial_Directory -- ----------------------- function Initial_Directory (Name : String) return String is Start : constant Integer := Index (Name, Dir_Separator & ""); begin -- Verify path name if not Is_Valid_Path_Name (Name) then raise Name_Error with "invalid path name """ & Name & '"'; end if; -- When there is no starting directory separator or the path name is a -- root directory then the path name is already simple - so return it. if Is_Root_Directory_Name (Name) or else Start = 0 then return Name; end if; -- When the initial directory of the path name is a root directory then -- the starting directory separator is part of the result so we must -- return it in the slice. if Is_Root_Directory_Name (Name (Name'First .. Start)) then return Name (Name'First .. Start); end if; -- Otherwise we grab a slice up to the starting directory separator return Name (Name'First .. Start - 1); end Initial_Directory; ------------------- -- Relative_Name -- ------------------- function Relative_Name (Name : String) return String is begin -- We cannot derive a relative name if Name does not exist if not Is_Relative_Name (Name) and then not Is_Valid_Path_Name (Name) then raise Name_Error with "invalid relative path name """ & Name & '"'; end if; -- Name only has a single part and thus cannot be made relative if Is_Simple_Name (Name) or else Is_Root_Directory_Name (Name) then raise Name_Error with "relative path name """ & Name & """ is composed of a single part"; end if; -- Trim the input according to the initial directory and maintain proper -- directory separation due to the fact that root directories may -- contain separators. declare Init_Dir : constant String := Initial_Directory (Name); begin if Init_Dir (Init_Dir'Last) = Dir_Separator then return Name (Name'First + Init_Dir'Length .. Name'Last); end if; return Name (Name'First + Init_Dir'Length + 1 .. Name'Last); end; end Relative_Name; ------------- -- Compose -- ------------- function Compose (Directory : String := ""; Relative_Name : String; Extension : String := "") return String is -- Append a directory separator if none is present Separated_Dir : constant String := (if Directory = "" then "" elsif Directory (Directory'Last) = Dir_Separator then Directory else Directory & Dir_Separator); begin -- Check that relative name is valid if not Is_Relative_Name (Relative_Name) then raise Name_Error with "invalid relative path name """ & Relative_Name & '"'; end if; -- Check that directory is valid if Separated_Dir /= "" and then (not Is_Valid_Path_Name (Separated_Dir & Relative_Name)) then raise Name_Error with "invalid path composition """ & Separated_Dir & Relative_Name & '"'; end if; -- Check that the extension is valid if Extension /= "" and then not Is_Valid_Path_Name (Separated_Dir & Relative_Name & Extension) then raise Name_Error with "invalid path composition """ & Separated_Dir & Relative_Name & Extension & '"'; end if; -- Concatenate the result return Separated_Dir & Relative_Name & Extension; end Compose; end Ada.Directories.Hierarchical_File_Names;