------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.DIRECTORIES.HIERARCHICAL_FILE_NAMES --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2020, 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;