333 lines
11 KiB
Ada
333 lines
11 KiB
Ada
|
------------------------------------------------------------------------------
|
||
|
|
-- --
|
||
|
|
-- 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;
|