Skip to content

Commit bb8580c

Browse files
pmderodatpmderodat
committed
GNATCOLL.File_Paths: new package
TN: V117-037 Change-Id: Ia9d755646676f1978efd9bb50a8444c74272caa0
1 parent b75ee2e commit bb8580c

File tree

12 files changed

+414
-0
lines changed

12 files changed

+414
-0
lines changed

‎src/gnatcoll-file_paths.adb‎

Lines changed: 164 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,164 @@
1+
------------------------------------------------------------------------------
2+
-- G N A T C O L L --
3+
-- --
4+
-- Copyright (C) 2022, AdaCore --
5+
-- --
6+
-- This library is free software; you can redistribute it and/or modify it --
7+
-- under terms of the GNU General Public License as published by the Free --
8+
-- Software Foundation; either version 3, or (at your option) any later --
9+
-- version. This library is distributed in the hope that it will be useful, --
10+
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
11+
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
12+
-- --
13+
-- As a special exception under Section 7 of GPL version 3, you are granted --
14+
-- additional permissions described in the GCC Runtime Library Exception, --
15+
-- version 3.1, as published by the Free Software Foundation. --
16+
-- --
17+
-- You should have received a copy of the GNU General Public License and --
18+
-- a copy of the GCC Runtime Library Exception along with this program; --
19+
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
20+
-- <http://www.gnu.org/licenses/>. --
21+
-- --
22+
------------------------------------------------------------------------------
23+
24+
with Ada.Directories; use Ada.Directories;
25+
with Ada.Environment_Variables;
26+
27+
with GNATCOLL.VFS; use GNATCOLL.VFS;
28+
29+
package body GNATCOLL.File_Paths is
30+
31+
procedure Append_CWD (Self : in out Any_Path);
32+
-- Append the current working directory to ``Self``
33+
34+
function File_Exists (Filename : String) return Boolean;
35+
-- Return whether the ``Filename`` file exists and is not a Directory
36+
37+
----------------
38+
-- Append_CWD --
39+
----------------
40+
41+
procedure Append_CWD (Self : in out Any_Path) is
42+
begin
43+
Self.Directories.Append (To_XString (Current_Directory));
44+
end Append_CWD;
45+
46+
-----------------
47+
-- File_Exists --
48+
-----------------
49+
50+
function File_Exists (Filename : String) return Boolean is
51+
begin
52+
return Kind (Filename) /= Directory;
53+
exception
54+
when Name_Error =>
55+
return False;
56+
end File_Exists;
57+
58+
-----------------
59+
-- Create_Path --
60+
-----------------
61+
62+
function Create_Path
63+
(Directories : XString_Array;
64+
CWD : CWD_Mode := CWD_First) return Any_Path is
65+
begin
66+
return Result : Any_Path do
67+
if CWD = CWD_Last then
68+
Append_CWD (Result);
69+
end if;
70+
71+
for D of reverse Directories loop
72+
if D.Is_Empty then
73+
74+
-- Empty components are interpreted as the current directory
75+
76+
Append_CWD (Result);
77+
78+
else
79+
-- Get the absolute file name for ``D``
80+
81+
declare
82+
Abs_Name : constant String :=
83+
+Create (+To_String (D), Normalize => True).Full_Name;
84+
begin
85+
Result.Directories.Append (To_XString (Abs_Name));
86+
end;
87+
end if;
88+
end loop;
89+
90+
if CWD = CWD_First or else Result.Directories.Is_Empty then
91+
Append_CWD (Result);
92+
end if;
93+
end return;
94+
end Create_Path;
95+
96+
------------------------------
97+
-- Create_Path_From_Environ --
98+
------------------------------
99+
100+
function Create_Path_From_Environ
101+
(Var_Name : String;
102+
Separator : Character := Path_Separator;
103+
CWD : CWD_Mode := CWD_First) return Any_Path is
104+
begin
105+
return Parse_Path
106+
(Ada.Environment_Variables.Value (Var_Name, ""),
107+
Separator,
108+
CWD);
109+
end Create_Path_From_Environ;
110+
111+
----------------
112+
-- Parse_Path --
113+
----------------
114+
115+
function Parse_Path
116+
(Path : String;
117+
Separator : Character := Path_Separator;
118+
CWD : CWD_Mode := CWD_First) return Any_Path is
119+
begin
120+
return Create_Path (To_XString (Path).Split (Separator), CWD);
121+
end Parse_Path;
122+
123+
-------------------
124+
-- Add_Directory --
125+
-------------------
126+
127+
procedure Add_Directory (Path : in out Any_Path; Directory : String) is
128+
begin
129+
Path.Directories.Append (To_XString (Directory));
130+
end Add_Directory;
131+
132+
------------
133+
-- Lookup --
134+
------------
135+
136+
function Lookup (Path : Any_Path; Filename : String) return String is
137+
begin
138+
if Create (+Filename).Is_Absolute_Path then
139+
140+
-- Lookup paths cannot help to find the file if the requested
141+
-- filename is already absolute: just check if it exists.
142+
143+
return (if File_Exists (Filename)
144+
then Filename
145+
else "");
146+
else
147+
-- Look for the given file in all directories in ``Path``
148+
149+
for D of reverse Path.Directories loop
150+
declare
151+
F : constant String :=
152+
To_String (D) & GNAT.OS_Lib.Directory_Separator & Filename;
153+
begin
154+
if File_Exists (F) then
155+
return F;
156+
end if;
157+
end;
158+
end loop;
159+
160+
return "";
161+
end if;
162+
end Lookup;
163+
164+
end GNATCOLL.File_Paths;

‎src/gnatcoll-file_paths.ads‎

Lines changed: 102 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,102 @@
1+
------------------------------------------------------------------------------
2+
-- G N A T C O L L --
3+
-- --
4+
-- Copyright (C) 2022, AdaCore --
5+
-- --
6+
-- This library is free software; you can redistribute it and/or modify it --
7+
-- under terms of the GNU General Public License as published by the Free --
8+
-- Software Foundation; either version 3, or (at your option) any later --
9+
-- version. This library is distributed in the hope that it will be useful, --
10+
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
11+
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
12+
-- --
13+
-- As a special exception under Section 7 of GPL version 3, you are granted --
14+
-- additional permissions described in the GCC Runtime Library Exception, --
15+
-- version 3.1, as published by the Free Software Foundation. --
16+
-- --
17+
-- You should have received a copy of the GNU General Public License and --
18+
-- a copy of the GCC Runtime Library Exception along with this program; --
19+
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
20+
-- <http://www.gnu.org/licenses/>. --
21+
-- --
22+
------------------------------------------------------------------------------
23+
24+
-- Implementation of path-based file lookups (like looking for a program in
25+
-- the ``PATH`` environment variable).
26+
27+
private with Ada.Containers.Vectors;
28+
29+
private with GNAT.OS_Lib;
30+
31+
with GNATCOLL.Strings; use GNATCOLL.Strings;
32+
33+
package GNATCOLL.File_Paths is
34+
35+
Path_Separator : constant Character;
36+
-- Default path separator on the current platform
37+
38+
type Any_Path is private;
39+
-- Path where to look for files, i.e. sequence of directories
40+
41+
type CWD_Mode is (If_Empty, CWD_First, CWD_Last);
42+
-- Control how to include the current working directory (CWD) to a path.
43+
--
44+
-- ``If_Empty``: automatically append it if the path would otherwise be
45+
-- empty.
46+
--
47+
-- ``CWD_First``: automatically append it first in the path (i.e. files are
48+
-- searched in priority in the CWD).
49+
--
50+
-- ``CWD_Last``: automatically append it last in the path (i.e. files are
51+
-- searched in the CWD as a last tentative).
52+
53+
function Create_Path
54+
(Directories : XString_Array;
55+
CWD : CWD_Mode := CWD_First) return Any_Path;
56+
-- Create a path for the given ``Directories`` (first directories are
57+
-- looked up before the next ones). ``CWD`` controls how to include the
58+
-- current working directory.
59+
60+
function Create_Path_From_Environ
61+
(Var_Name : String;
62+
Separator : Character := Path_Separator;
63+
CWD : CWD_Mode := CWD_First) return Any_Path;
64+
-- Create a path for the directories listed in the ``Var_Name`` environment
65+
-- variable. Each path component is separated by ``Separator``. ``CWD``
66+
-- controls how to include the current working directory.
67+
68+
function Parse_Path
69+
(Path : String;
70+
Separator : Character := Path_Separator;
71+
CWD : CWD_Mode := CWD_First) return Any_Path;
72+
-- Parse a path from the ``Path`` string. Each path component is separated
73+
-- by ``Separator``. ``CWD`` controls how to include the current working
74+
-- directory.
75+
76+
procedure Add_Directory (Path : in out Any_Path; Directory : String);
77+
-- Add ``Directory`` to the given ``Path``. This new directory takes
78+
-- precedence over the existing ones for file lookups.
79+
80+
function Lookup (Path : Any_Path; Filename : String) return String;
81+
-- Look for a filed called ``Filename`` in directories referenced by
82+
-- ``Path`` and return its absolute file name. If the file is not found,
83+
-- return an empty string.
84+
85+
Empty_Path : constant Any_Path;
86+
-- Path for which only lookups on existing absolute file names will succeed
87+
88+
private
89+
90+
Path_Separator : constant Character := GNAT.OS_Lib.Path_Separator;
91+
92+
package String_Vectors is new Ada.Containers.Vectors (Positive, XString);
93+
94+
type Any_Path is record
95+
Directories : String_Vectors.Vector;
96+
-- Last directories have precedence over the first ones for file lookups
97+
end record;
98+
99+
Empty_Path : constant Any_Path :=
100+
(Directories => String_Vectors.Empty_Vector);
101+
102+
end GNATCOLL.File_Paths;

‎testsuite/tests/file_paths/bar‎

Whitespace-only changes.

‎testsuite/tests/file_paths/dir1/foo‎

Whitespace-only changes.

‎testsuite/tests/file_paths/dir2/bar‎

Whitespace-only changes.

‎testsuite/tests/file_paths/dir2/foo‎

Whitespace-only changes.

‎testsuite/tests/file_paths/foo/.gitignore‎

Whitespace-only changes.

‎testsuite/tests/file_paths/test.adb‎

Lines changed: 85 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,85 @@
1+
with Ada.Text_IO; use Ada.Text_IO;
2+
3+
with GNATCOLL.Strings; use GNATCOLL.Strings;
4+
with GNATCOLL.VFS; use GNATCOLL.VFS;
5+
6+
with GNATCOLL.File_Paths; use GNATCOLL.File_Paths;
7+
8+
procedure Test is
9+
10+
CWD : constant Virtual_File := Get_Current_Dir;
11+
12+
function Filename_Image (Filename : String) return String;
13+
-- If ``Filename`` is absolute, transform it to make the test output stable
14+
15+
Check_Components : constant XString_Array :=
16+
(To_XString ("bar"),
17+
To_XString ("foo"),
18+
To_XString ("dir1/bar"),
19+
To_XString ("dir1/foo"),
20+
To_XString ("dir2/foo"),
21+
To_XString (+CWD.Full_Name & "dir1/foo"));
22+
23+
procedure Check (Path : String; Separator : Character; CWD : CWD_Mode);
24+
-- Parse ``Path`` with the given arguments and show the attempt to look up
25+
-- items in ``Check_Components`` on the resulting path.
26+
27+
--------------------
28+
-- Filename_Image --
29+
--------------------
30+
31+
function Filename_Image (Filename : String) return String is
32+
F : constant Virtual_File := Create (+Filename);
33+
begin
34+
if F.Is_Absolute_Path then
35+
return "abs(""" & (+F.Relative_Path (CWD)) & """)";
36+
else
37+
return """" & Filename & """";
38+
end if;
39+
end Filename_Image;
40+
41+
-----------
42+
-- Check --
43+
-----------
44+
45+
procedure Check (Path : String; Separator : Character; CWD : CWD_Mode) is
46+
Label : constant String :=
47+
"""" & Path & """, '" & Separator & "', " & CWD'Image;
48+
49+
P : Any_Path;
50+
begin
51+
Put_Line (Label);
52+
Put_Line ((1 .. Label'Length => '='));
53+
New_Line;
54+
55+
P := Parse_Path (Path, Separator, CWD);
56+
for C of Check_Components loop
57+
declare
58+
S : constant String := To_String (C);
59+
begin
60+
Put_Line
61+
(Filename_Image (S) & ": " & Filename_Image (Lookup (P, S)));
62+
end;
63+
end loop;
64+
65+
New_Line;
66+
end Check;
67+
68+
begin
69+
-- The empty path is equivalent to the current working directory
70+
71+
Check ("", Path_Separator, If_Empty);
72+
73+
-- First items in the path have priority
74+
75+
Check ("dir1|dir2", '|', If_Empty);
76+
Check ("dir2|dir1", '|', If_Empty);
77+
78+
-- Check first/last CWD modes. The "bar" file is present both in "dir2" and
79+
-- in CWD, so its location should be different in the two cases below.
80+
81+
Check ("dir2", '|', CWD_First);
82+
Check ("dir2", '|', CWD_Last);
83+
84+
Put_Line ("Done.");
85+
end Test;

‎testsuite/tests/file_paths/test.gpr‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
with "gnatcoll";
2+
3+
project Test is
4+
for Main use ("test.adb");
5+
for Object_Dir use "obj";
6+
for Exec_Dir use ".";
7+
end Test;

0 commit comments

Comments
 (0)