[Ada] Implement Ada.Directories.Hierarchical_File_Names
This patch corrects certain behaviors within Ada.Directories to better
conform to conformance tests and implements the package
Ada.Directories.Hierarchical_File_Names outlined in AI05-0049-1.
Only partial test sources are included.
------------
-- Source --
------------
-- main.ads
with Ada.Directories.Hierarchical_File_Names;
use Ada.Directories.Hierarchical_File_Names;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Text_IO; use Ada.Text_IO;
procedure Main is
FULL_PATH_A : constant String := "/export/work/user/bug";
FULL_PATH_B : constant String := "/export/work/user";
RELATIVE_PATH_A : constant String := "export/work/user/bug/";
RELATIVE_PATH_B : constant String := "export/work/user/bug";
SIMPLE_PATH_A : constant String := "bug/";
SIMPLE_PATH_B : constant String := "bug";
ROOT_PATH : constant String := "/";
CURRENT_DIR : constant String := ".";
PARENT_DIR : constant String := "..";
RELATIVE_WITH_CURRENT : constant String := RELATIVE_PATH_A & ".";
RELATIVE_WITH_PARENT : constant String := RELATIVE_PATH_A & "..";
begin
Put_Line ("Simple_Name");
Put_Line (Is_Simple_Name (FULL_PATH_A)'Image);
Put_Line (Is_Simple_Name (FULL_PATH_B)'Image);
Put_Line (Is_Simple_Name (RELATIVE_PATH_A)'Image);
Put_Line (Is_Simple_Name (RELATIVE_PATH_B)'Image);
Put_Line (Is_Simple_Name (SIMPLE_PATH_A)'Image);
Put_Line (Is_Simple_Name (SIMPLE_PATH_B)'Image);
Put_Line (Is_Simple_Name (ROOT_PATH)'Image);
Put_Line (Is_Simple_Name (CURRENT_DIR)'Image);
Put_Line (Is_Simple_Name (PARENT_DIR)'Image);
Put_Line (Is_Simple_Name (RELATIVE_WITH_CURRENT)'Image);
Put_Line (Is_Simple_Name (RELATIVE_WITH_PARENT)'Image);
Put_Line (Simple_Name (FULL_PATH_A));
Put_Line (Simple_Name (FULL_PATH_B));
Put_Line (Simple_Name (RELATIVE_PATH_A));
Put_Line (Simple_Name (RELATIVE_PATH_B));
Put_Line (Simple_Name (SIMPLE_PATH_A));
Put_Line (Simple_Name (SIMPLE_PATH_B));
Put_Line (Simple_Name (ROOT_PATH));
Put_Line (Simple_Name (CURRENT_DIR));
Put_Line (Simple_Name (PARENT_DIR));
Put_Line (Simple_Name (RELATIVE_WITH_CURRENT));
Put_Line (Simple_Name (RELATIVE_WITH_PARENT));
Put_Line ("Root_Directory_Name");
Put_Line (Is_Root_Directory_Name (FULL_PATH_A)'Image);
Put_Line (Is_Root_Directory_Name (FULL_PATH_B)'Image);
Put_Line (Is_Root_Directory_Name (RELATIVE_PATH_A)'Image);
Put_Line (Is_Root_Directory_Name (RELATIVE_PATH_B)'Image);
Put_Line (Is_Root_Directory_Name (SIMPLE_PATH_A)'Image);
Put_Line (Is_Root_Directory_Name (SIMPLE_PATH_B)'Image);
Put_Line (Is_Root_Directory_Name (ROOT_PATH)'Image);
Put_Line (Is_Root_Directory_Name (CURRENT_DIR)'Image);
Put_Line (Is_Root_Directory_Name (PARENT_DIR)'Image);
Put_Line (Is_Root_Directory_Name (RELATIVE_WITH_CURRENT)'Image);
Put_Line (Is_Root_Directory_Name (RELATIVE_WITH_PARENT)'Image);
Put_Line ("Is_Parent_Directory_Name");
Put_Line (Is_Parent_Directory_Name (FULL_PATH_A)'Image);
Put_Line (Is_Parent_Directory_Name (FULL_PATH_B)'Image);
Put_Line (Is_Parent_Directory_Name (RELATIVE_PATH_A)'Image);
Put_Line (Is_Parent_Directory_Name (RELATIVE_PATH_B)'Image);
Put_Line (Is_Parent_Directory_Name (SIMPLE_PATH_A)'Image);
Put_Line (Is_Parent_Directory_Name (SIMPLE_PATH_B)'Image);
Put_Line (Is_Parent_Directory_Name (ROOT_PATH)'Image);
Put_Line (Is_Parent_Directory_Name (CURRENT_DIR)'Image);
Put_Line (Is_Parent_Directory_Name (PARENT_DIR)'Image);
Put_Line (Is_Parent_Directory_Name (RELATIVE_WITH_CURRENT)'Image);
Put_Line (Is_Parent_Directory_Name (RELATIVE_WITH_PARENT)'Image);
Put_Line ("Is_Current_Directory_Name");
Put_Line (Is_Current_Directory_Name (FULL_PATH_A)'Image);
Put_Line (Is_Current_Directory_Name (FULL_PATH_B)'Image);
Put_Line (Is_Current_Directory_Name (RELATIVE_PATH_A)'Image);
Put_Line (Is_Current_Directory_Name (RELATIVE_PATH_B)'Image);
Put_Line (Is_Current_Directory_Name (SIMPLE_PATH_A)'Image);
Put_Line (Is_Current_Directory_Name (SIMPLE_PATH_B)'Image);
Put_Line (Is_Current_Directory_Name (ROOT_PATH)'Image);
Put_Line (Is_Current_Directory_Name (CURRENT_DIR)'Image);
Put_Line (Is_Current_Directory_Name (PARENT_DIR)'Image);
Put_Line (Is_Current_Directory_Name (RELATIVE_WITH_CURRENT)'Image);
Put_Line (Is_Current_Directory_Name (RELATIVE_WITH_PARENT)'Image);
Put_Line ("Is_Full_Name");
Put_Line (Is_Full_Name (FULL_PATH_A)'Image);
Put_Line (Is_Full_Name (FULL_PATH_B)'Image);
Put_Line (Is_Full_Name (RELATIVE_PATH_A)'Image);
Put_Line (Is_Full_Name (RELATIVE_PATH_B)'Image);
Put_Line (Is_Full_Name (SIMPLE_PATH_A)'Image);
Put_Line (Is_Full_Name (SIMPLE_PATH_B)'Image);
Put_Line (Is_Full_Name (ROOT_PATH)'Image);
Put_Line (Is_Full_Name (CURRENT_DIR)'Image);
Put_Line (Is_Full_Name (PARENT_DIR)'Image);
Put_Line (Is_Full_Name (RELATIVE_WITH_CURRENT)'Image);
Put_Line (Is_Full_Name (RELATIVE_WITH_PARENT)'Image);
Put_Line ("Relative_Name");
Put_Line (Is_Relative_Name (FULL_PATH_A)'Image);
Put_Line (Is_Relative_Name (FULL_PATH_B)'Image);
Put_Line (Is_Relative_Name (RELATIVE_PATH_A)'Image);
Put_Line (Is_Relative_Name (RELATIVE_PATH_B)'Image);
Put_Line (Is_Relative_Name (SIMPLE_PATH_A)'Image);
Put_Line (Is_Relative_Name (SIMPLE_PATH_B)'Image);
Put_Line (Is_Relative_Name (ROOT_PATH)'Image);
Put_Line (Is_Relative_Name (CURRENT_DIR)'Image);
Put_Line (Is_Relative_Name (PARENT_DIR)'Image);
Put_Line (Is_Relative_Name (RELATIVE_WITH_CURRENT)'Image);
Put_Line (Is_Relative_Name (RELATIVE_WITH_PARENT)'Image);
Put_Line (Relative_Name (FULL_PATH_A));
Put_Line (Relative_Name (FULL_PATH_B));
Put_Line (Relative_Name (RELATIVE_PATH_A));
Put_Line (Relative_Name (RELATIVE_PATH_B));
begin
Put_Line (Relative_Name (SIMPLE_PATH_A));
exception
when E: others =>
Put_Line (Exception_Information (E));
end;
begin
Put_Line (Relative_Name (SIMPLE_PATH_B));
exception
when E: others =>
Put_Line (Exception_Information (E));
end;
begin
Put_Line (Relative_Name (ROOT_PATH));
exception
when E: others =>
Put_Line (Exception_Information (E));
end;
begin
Put_Line (Relative_Name (CURRENT_DIR));
exception
when E: others =>
Put_Line (Exception_Information (E));
end;
begin
Put_Line (Relative_Name (PARENT_DIR));
exception
when E: others =>
Put_Line (Exception_Information (E));
end;
Put_Line (Relative_Name (RELATIVE_WITH_CURRENT));
Put_Line (Relative_Name (RELATIVE_WITH_PARENT));
Put_Line ("Containing_Directory");
Put_Line (Containing_Directory (FULL_PATH_A));
Put_Line (Containing_Directory (FULL_PATH_B));
Put_Line (Containing_Directory (RELATIVE_PATH_A));
Put_Line (Containing_Directory (RELATIVE_PATH_B));
Put_Line (Containing_Directory (SIMPLE_PATH_A));
Put_Line (Containing_Directory (SIMPLE_PATH_B));
begin
Put_Line (Containing_Directory (ROOT_PATH));
exception
when E: others =>
Put_Line (Exception_Information (E));
end;
begin
Put_Line (Containing_Directory (CURRENT_DIR));
exception
when E: others =>
Put_Line (Exception_Information (E));
end;
begin
Put_Line (Containing_Directory (PARENT_DIR));
exception
when E: others =>
Put_Line (Exception_Information (E));
end;
Put_Line (Containing_Directory (RELATIVE_WITH_CURRENT));
Put_Line (Containing_Directory (RELATIVE_WITH_PARENT));
Put_Line ("Initial_Directory");
Put_Line (Initial_Directory (FULL_PATH_A));
Put_Line (Initial_Directory (FULL_PATH_B));
Put_Line (Initial_Directory (RELATIVE_PATH_A));
Put_Line (Initial_Directory (RELATIVE_PATH_B));
Put_Line (Initial_Directory (SIMPLE_PATH_A));
Put_Line (Initial_Directory (SIMPLE_PATH_B));
Put_Line (Initial_Directory (ROOT_PATH));
Put_Line (Initial_Directory (CURRENT_DIR));
Put_Line (Initial_Directory (PARENT_DIR));
Put_Line (Initial_Directory (RELATIVE_WITH_CURRENT));
Put_Line (Initial_Directory (RELATIVE_WITH_PARENT));
end;
-----------------
-- Compilation --
-----------------
$ gnatmake -q main.adb
Simple_Name
FALSE
FALSE
FALSE
FALSE
TRUE
TRUE
FALSE
TRUE
TRUE
FALSE
FALSE
bug
user
bug
bug
bug
bug
/
.
..
.
..
Root_Directory_Name
FALSE
FALSE
FALSE
FALSE
FALSE
FALSE
TRUE
FALSE
FALSE
FALSE
FALSE
Is_Parent_Directory_Name
FALSE
FALSE
FALSE
FALSE
FALSE
FALSE
FALSE
FALSE
TRUE
FALSE
FALSE
Is_Current_Directory_Name
FALSE
FALSE
FALSE
FALSE
FALSE
FALSE
FALSE
TRUE
FALSE
FALSE
FALSE
Is_Full_Name
TRUE
TRUE
FALSE
FALSE
FALSE
FALSE
TRUE
FALSE
FALSE
FALSE
FALSE
Relative_Name
FALSE
FALSE
TRUE
TRUE
TRUE
TRUE
FALSE
TRUE
TRUE
TRUE
TRUE
export/work/user/bug
export/work/user
work/user/bug/
work/user/bug
raised ADA.IO_EXCEPTIONS.NAME_ERROR : relative path name "bug/" is
composed of a single part
raised ADA.IO_EXCEPTIONS.NAME_ERROR : relative path name "bug" is
composed of a single part
raised ADA.IO_EXCEPTIONS.NAME_ERROR : relative path name "/" is
composed of a single part
raised ADA.IO_EXCEPTIONS.NAME_ERROR : relative path name "." is
composed of a single part
raised ADA.IO_EXCEPTIONS.NAME_ERROR : relative path name ".." is
composed of a single part
work/user/bug/.
work/user/bug/..
Containing_Directory
/export/work/user
/export/work
export/work/user/bug
export/work/user
bug
.
raised ADA.IO_EXCEPTIONS.USE_ERROR : directory "/" has no containing directory
raised ADA.IO_EXCEPTIONS.USE_ERROR : directory "." has no containing directory
raised ADA.IO_EXCEPTIONS.USE_ERROR : directory ".." has no containing directory
export/work/user/bug
export/work/user/bug
Initial_Directory
/
/
export
export
bug
bug
/
.
..
export
export
2019-08-12 Justin Squirek <squirek@adacore.com>
gcc/ada/
* libgnat/a-dhfina.adb, libgnat/a-dhfina.ads (Is_Simple_Name,
Is_Root_Directory, Is_Parent_Directory,
Is_Current_Directory_Name, Is_Relative_Name, Initial_Directory,
Relative_Name, Compose): Add implementation and documentation.
* libgnat/a-direct.adb (Containing_Directory): Modify routine to
use routines from Ada.Directories.Hierarchical_File_Names and
remove incorrect special case for parent directories.
(Fetch_Next_Entry): Add check for current directory and parent
directory and ignore them under certain circumstances.
(Simple_Nmae): Add check for null result from
Simple_Name_Internal and raise Name_Error.
(Simple_Name_Internal): Add explicit check for root directories,
sanitize trailing directory separators, and modify behavior so
that current and parent directories are considered valid
results.
* Makefile.rtl: Add entry to GNATRTL_NONTASKING_OBJS.
From-SVN: r274295
This commit is contained in:
Justin Squirek
Pierre-Marie de Rodat
parent
62f0fa2170
commit
5076fb182e
|
|
@ -1,3 +1,22 @@
|
|||
2019-08-12 Justin Squirek <squirek@adacore.com>
|
||||
|
||||
* libgnat/a-dhfina.adb, libgnat/a-dhfina.ads (Is_Simple_Name,
|
||||
Is_Root_Directory, Is_Parent_Directory,
|
||||
Is_Current_Directory_Name, Is_Relative_Name, Initial_Directory,
|
||||
Relative_Name, Compose): Add implementation and documentation.
|
||||
* libgnat/a-direct.adb (Containing_Directory): Modify routine to
|
||||
use routines from Ada.Directories.Hierarchical_File_Names and
|
||||
remove incorrect special case for parent directories.
|
||||
(Fetch_Next_Entry): Add check for current directory and parent
|
||||
directory and ignore them under certain circumstances.
|
||||
(Simple_Nmae): Add check for null result from
|
||||
Simple_Name_Internal and raise Name_Error.
|
||||
(Simple_Name_Internal): Add explicit check for root directories,
|
||||
sanitize trailing directory separators, and modify behavior so
|
||||
that current and parent directories are considered valid
|
||||
results.
|
||||
* Makefile.rtl: Add entry to GNATRTL_NONTASKING_OBJS.
|
||||
|
||||
2019-08-12 Eric Botcazou <ebotcazou@adacore.com>
|
||||
|
||||
* freeze.adb (Freeze_Entity): Give the same error for an
|
||||
|
|
|
|||
|
|
@ -171,6 +171,7 @@ GNATRTL_NONTASKING_OBJS= \
|
|||
a-cwila1$(objext) \
|
||||
a-cwila9$(objext) \
|
||||
a-decima$(objext) \
|
||||
a-dhfina$(objext) \
|
||||
a-diocst$(objext) \
|
||||
a-direct$(objext) \
|
||||
a-direio$(objext) \
|
||||
|
|
|
|||
|
|
@ -0,0 +1,332 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUN-TIME COMPONENTS --
|
||||
-- --
|
||||
-- ADA.DIRECTORIES.HIERARCHICAL_FILE_NAMES --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2004-2019, 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;
|
||||
|
|
@ -6,41 +6,101 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- This specification is derived from the Ada Reference Manual for use with --
|
||||
-- GNAT. In accordance with the copyright of that document, you can freely --
|
||||
-- copy and modify this specification, provided that if you redistribute a --
|
||||
-- modified version, any changes that you have made are clearly indicated. --
|
||||
-- Copyright (C) 2004-2019, 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. --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
package Ada.Directories.Hierarchical_File_Names is
|
||||
pragma Unimplemented_Unit;
|
||||
|
||||
function Is_Simple_Name (Name : String) return Boolean;
|
||||
-- Returns True if Name is a simple name, and returns False otherwise.
|
||||
|
||||
function Is_Root_Directory_Name (Name : String) return Boolean;
|
||||
-- Returns True if Name is syntactically a root (a directory that cannot
|
||||
-- be decomposed further), and returns False otherwise.
|
||||
|
||||
function Is_Parent_Directory_Name (Name : String) return Boolean;
|
||||
-- Returns True if Name can be used to indicate symbolically the parent
|
||||
-- directory of any directory, and returns False otherwise.
|
||||
|
||||
function Is_Current_Directory_Name (Name : String) return Boolean;
|
||||
-- Returns True if Name can be used to indicate symbolically the directory
|
||||
-- itself for any directory, and returns False otherwise.
|
||||
|
||||
function Is_Full_Name (Name : String) return Boolean;
|
||||
-- Returns True if the leftmost directory part of Name is a root, and
|
||||
-- returns False otherwise.
|
||||
|
||||
function Is_Relative_Name (Name : String) return Boolean;
|
||||
-- Returns True if Name allows the identification of an external file
|
||||
-- (including directories and special files) but is not a full name, and
|
||||
-- returns False otherwise.
|
||||
|
||||
function Simple_Name (Name : String) return String
|
||||
renames Ada.Directories.Simple_Name;
|
||||
-- Returns the simple name portion of the file name specified by Name. The
|
||||
-- exception Name_Error is propagated if the string given as Name does not
|
||||
-- allow the identification of an external file (including directories and
|
||||
-- special files).
|
||||
|
||||
function Containing_Directory (Name : String) return String
|
||||
renames Ada.Directories.Containing_Directory;
|
||||
-- Returns the name of the containing directory of the external file
|
||||
-- (including directories) identified by Name. If more than one directory
|
||||
-- can contain Name, the directory name returned is implementation-defined.
|
||||
-- The exception Name_Error is propagated if the string given as Name does
|
||||
-- not allow the identification of an external file. The exception
|
||||
-- Use_Error is propagated if the external file does not have a containing
|
||||
-- directory.
|
||||
|
||||
function Initial_Directory (Name : String) return String;
|
||||
-- Returns the leftmost directory part in Name. That is, it returns a root
|
||||
-- directory name (for a full name), or one of a parent directory name, a
|
||||
-- current directory name, or a simple name (for a relative name). The
|
||||
-- exception Name_Error is propagated if the string given as Name does not
|
||||
-- allow the identification of an external file (including directories and
|
||||
-- special files).
|
||||
|
||||
function Relative_Name (Name : String) return String;
|
||||
-- Returns the entire file name except the Initial_Directory portion. The
|
||||
-- exception Name_Error is propagated if the string given as Name does not
|
||||
-- allow the identification of an external file (including directories and
|
||||
-- special files), or if Name has a single part (this includes if any of
|
||||
-- Is_Simple_Name, Is_Root_Directory_Name, Is_Parent_Directory_Name, or
|
||||
-- Is_Current_Directory_Name are True).
|
||||
|
||||
function Compose
|
||||
(Directory : String := "";
|
||||
Relative_Name : String;
|
||||
Extension : String := "") return String;
|
||||
-- Returns the name of the external file with the specified Directory,
|
||||
-- Relative_Name, and Extension. The exception Name_Error is propagated if
|
||||
-- the string given as Directory is not the null string and does not allow
|
||||
-- the identification of a directory, or if Is_Relative_Name
|
||||
-- (Relative_Name) is False, or if the string given as Extension is not
|
||||
-- the null string and is not a possible extension, or if Extension is not
|
||||
-- the null string and Simple_Name (Relative_Name) is not a base name.
|
||||
--
|
||||
-- The result of Compose is a full name if Is_Full_Name (Directory) is
|
||||
-- True; result is a relative name otherwise.
|
||||
|
||||
end Ada.Directories.Hierarchical_File_Names;
|
||||
|
|
|
|||
|
|
@ -33,6 +33,8 @@ with Ada.Calendar; use Ada.Calendar;
|
|||
with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;
|
||||
with Ada.Characters.Handling; use Ada.Characters.Handling;
|
||||
with Ada.Directories.Validity; use Ada.Directories.Validity;
|
||||
with Ada.Directories.Hierarchical_File_Names;
|
||||
use Ada.Directories.Hierarchical_File_Names;
|
||||
with Ada.Strings.Fixed;
|
||||
with Ada.Strings.Maps; use Ada.Strings.Maps;
|
||||
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
||||
|
|
@ -224,31 +226,22 @@ package body Ada.Directories is
|
|||
Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward);
|
||||
|
||||
begin
|
||||
if Last_DS = 0 then
|
||||
|
||||
-- There is no directory separator, returns "." representing
|
||||
-- the current working directory.
|
||||
|
||||
return ".";
|
||||
|
||||
-- If Name indicates a root directory, raise Use_Error, because
|
||||
-- it has no containing directory.
|
||||
|
||||
elsif Name = "/"
|
||||
or else
|
||||
(Windows
|
||||
and then
|
||||
(Name = "\"
|
||||
or else
|
||||
(Name'Length = 3
|
||||
and then Name (Name'Last - 1 .. Name'Last) = ":\"
|
||||
and then (Name (Name'First) in 'a' .. 'z'
|
||||
or else
|
||||
Name (Name'First) in 'A' .. 'Z'))))
|
||||
if Is_Parent_Directory_Name (Name)
|
||||
or else Is_Current_Directory_Name (Name)
|
||||
or else Is_Root_Directory_Name (Name)
|
||||
then
|
||||
raise Use_Error with
|
||||
"directory """ & Name & """ has no containing directory";
|
||||
|
||||
elsif Last_DS = 0 then
|
||||
-- There is no directory separator, so return ".", representing
|
||||
-- the current working directory.
|
||||
|
||||
return ".";
|
||||
|
||||
else
|
||||
declare
|
||||
Last : Positive := Last_DS - Name'First + 1;
|
||||
|
|
@ -262,31 +255,14 @@ package body Ada.Directories is
|
|||
-- number on Windows.
|
||||
|
||||
while Last > 1 loop
|
||||
exit when
|
||||
Result (Last) /= '/'
|
||||
and then
|
||||
Result (Last) /= Directory_Separator;
|
||||
|
||||
exit when Windows
|
||||
and then Last = 3
|
||||
and then Result (2) = ':'
|
||||
and then
|
||||
(Result (1) in 'A' .. 'Z'
|
||||
or else
|
||||
Result (1) in 'a' .. 'z');
|
||||
exit when Is_Root_Directory_Name (Result (1 .. Last))
|
||||
or else (Result (Last) /= Directory_Separator
|
||||
and then Result (Last) /= '/');
|
||||
|
||||
Last := Last - 1;
|
||||
end loop;
|
||||
|
||||
-- Special case of "..": the current directory may be a root
|
||||
-- directory.
|
||||
|
||||
if Last = 2 and then Result (1 .. 2) = ".." then
|
||||
return Containing_Directory (Current_Directory);
|
||||
|
||||
else
|
||||
return Result (1 .. Last);
|
||||
end if;
|
||||
return Result (1 .. Last);
|
||||
end;
|
||||
end if;
|
||||
end;
|
||||
|
|
@ -806,6 +782,20 @@ package body Ada.Directories is
|
|||
end if;
|
||||
|
||||
if Exists = 1 then
|
||||
-- Ignore special directories "." and ".."
|
||||
|
||||
if (Full_Name'Length > 1
|
||||
and then
|
||||
Full_Name
|
||||
(Full_Name'Last - 1 .. Full_Name'Last) = "\.")
|
||||
or else
|
||||
(Full_Name'Length > 2
|
||||
and then
|
||||
Full_Name
|
||||
(Full_Name'Last - 2 .. Full_Name'Last) = "\..")
|
||||
then
|
||||
Exists := 0;
|
||||
end if;
|
||||
|
||||
-- Now check if the file kind matches the filter
|
||||
|
||||
|
|
@ -1280,17 +1270,31 @@ package body Ada.Directories is
|
|||
function Simple_Name_Internal (Path : String) return String is
|
||||
Cut_Start : Natural :=
|
||||
Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward);
|
||||
Cut_End : Natural;
|
||||
|
||||
-- Cut_End points to the last simple name character
|
||||
|
||||
Cut_End : Natural := Path'Last;
|
||||
|
||||
begin
|
||||
-- Cut_Start pointS to the first simple name character
|
||||
-- Root directories are considered simple
|
||||
|
||||
if Is_Root_Directory_Name (Path) then
|
||||
return Path;
|
||||
end if;
|
||||
|
||||
-- Handle trailing directory separators
|
||||
|
||||
if Cut_Start = Path'Last then
|
||||
Cut_End := Path'Last - 1;
|
||||
Cut_Start := Strings.Fixed.Index
|
||||
(Path (Path'First .. Path'Last - 1),
|
||||
Dir_Seps, Going => Strings.Backward);
|
||||
end if;
|
||||
|
||||
-- Cut_Start points to the first simple name character
|
||||
|
||||
Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
|
||||
|
||||
-- Cut_End point to the last simple name character
|
||||
|
||||
Cut_End := Path'Last;
|
||||
|
||||
Check_For_Standard_Dirs : declare
|
||||
BN : constant String := Path (Cut_Start .. Cut_End);
|
||||
|
||||
|
|
@ -1301,7 +1305,7 @@ package body Ada.Directories is
|
|||
|
||||
begin
|
||||
if BN = "." or else BN = ".." then
|
||||
return "";
|
||||
return BN;
|
||||
|
||||
elsif Has_Drive_Letter
|
||||
and then BN'Length > 2
|
||||
|
|
|
|||
Loading…
Reference in New Issue