Skip to content

Commit

Permalink
Fix traversal of dirs containing troublesome softlinks (#1718)
Browse files Browse the repository at this point in the history 
* Fix enumeration of files with troublesome softlinks

* Self-review

* Workaround in `den` for GCC 14 C++ bug

* 2nd self-review

commit 7d8b2cc
Author: Alejandro R. Mosteo <[email protected]>
Date:   Fri Aug 2 09:53:22 2024 +0200

    Debug trouble with relative path finder

commit 0951457
Author: Alejandro R. Mosteo <[email protected]>
Date:   Thu Aug 1 22:32:48 2024 +0200

    Use simpler relative path from Den

commit 76417fa
Author: Alejandro R. Mosteo <[email protected]>
Date:   Thu Aug 1 22:32:09 2024 +0200

    Revert "Try with gprbuild<24"

    This reverts commit b6ca84e.

commit f6e0a96
Author: Alejandro R. Mosteo <[email protected]>
Date:   Thu Aug 1 00:04:00 2024 +0200

    Repair find relative part output

commit 6ad595f
Author: Alejandro R. Mosteo <[email protected]>
Date:   Wed Jul 31 23:28:48 2024 +0200

    Flush testsuite output at start

commit a52e555
Author: Alejandro R. Mosteo <[email protected]>
Date:   Wed Jul 31 18:18:44 2024 +0200

    Fix damaged test

commit b6ca84e
Author: Alejandro R. Mosteo <[email protected]>
Date:   Wed Jul 31 14:16:11 2024 +0200

    Try with gprbuild<24

commit 5000210
Author: Alejandro R. Mosteo <[email protected]>
Date:   Wed Jul 31 14:04:07 2024 +0200

    Show GNAT/GPRBUILD versions prior to testsuite run
  • Loading branch information
@mosteo
mosteo authored Aug 7, 2024
1 parent 134d115 commit 6668490
Show file tree
Hide file tree
Showing 18 changed files with 182 additions and 175 deletions.
12 changes: 11 additions & 1 deletion .github/workflows/ci-docker.yml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,8 +32,18 @@ jobs:
with:
submodules: true

- name: OS information for ${{ matrix.tag }}
uses: mosteo-actions/docker-run@v2
with:
image: ghcr.io/alire-project/docker/gnat:${{matrix.tag}}
command: |
lsb_release -a || \
cat /etc/os-release || \
cat /etc/system-release || \
echo "No lsb_release information"
- name: Run test script (${{ matrix.tag }})
uses: mosteo-actions/docker-run@v1
uses: mosteo-actions/docker-run@v2
with:
image: ghcr.io/alire-project/docker/gnat:${{matrix.tag}}
command: scripts/ci-github.sh
Expand Down
8 changes: 6 additions & 2 deletions scripts/ci-github.sh
View file
Original file line number Diff line number Diff line change
Expand Up @@ -51,8 +51,8 @@ echo GNAT VERSION:
gnatls -v
echo ............................

echo ALR VERSION:
alr version
echo "ALR VERSION (at $(which alr)):"
alr -d version
echo ............................

# Set up index if not default:
Expand All @@ -61,6 +61,10 @@ if [ "${INDEX:-}" != "" ]; then
alr index --name default --add "$INDEX"
fi

echo "ALR SETTINGS (global):"
alr settings --global
echo ............................

echo ALR SEARCH:
# List releases for the record
alr -q -d search --list --external
Expand Down
204 changes: 72 additions & 132 deletions src/alire/alire-directories.adb
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,9 @@ with Alire.Platforms.Folders;
with Alire.VFS;
with Alire.Utils;

with Den.Filesystem;
with Den.Walk;

with GNAT.String_Hash;

with GNATCOLL.VFS;
Expand Down Expand Up @@ -392,51 +395,35 @@ package body Alire.Directories is
Max_Depth : Natural := Natural'Last)
return AAA.Strings.Vector
is
use all type Den.Kinds;
Found : AAA.Strings.Vector;

procedure Locate (Folder : String;
Current_Depth : Natural;
Max_Depth : Natural)
-----------
-- Check --
-----------

procedure Check (Item : Den.Walk.Item;
Enter : in out Boolean;
Stop : in out Boolean)
is
use Ada.Directories;
Search : Search_Type;
begin
Start_Search (Search, Folder, "",
Filter => (Ordinary_File => True,
Directory => True,
others => False));

while More_Entries (Search) loop
declare
Current : Directory_Entry_Type;
begin
Get_Next_Entry (Search, Current);
if Kind (Current) = Directory then
if Simple_Name (Current) /= "."
and then
Simple_Name (Current) /= ".."
and then
Current_Depth < Max_Depth
then
Locate (Folder / Simple_Name (Current),
Current_Depth + 1,
Max_Depth);
end if;
elsif Kind (Current) = Ordinary_File
and then Simple_Name (Current) = Simple_Name (Name)
then
Found.Append (Folder / Name);
end if;
end;
end loop;
Stop := False;

End_Search (Search);
end Locate;
if Max_Depth < Natural'Last and then Item.Depth > Max_Depth then
Enter := False;
end if;

if Den.Kind (Item.Path) = File
and then Den.Name (Item.Path) = Den.Name (Name)
then
Found.Append (Item.Path);
end if;
end Check;

use Ada.Directories;
begin
if Exists (Folder) and then Kind (Folder) = Directory then
Locate (Folder, 0, Max_Depth);
if Den.Exists (Folder) and then Den.Kind (Folder) = Den.Directory then
Den.Walk.Find (Folder,
Check'Access);
end if;

return Found;
Expand All @@ -451,7 +438,9 @@ package body Alire.Directories is
return Any_Path
is
begin
return AAA.Directories.Relative_Path (Parent, Child);
return Result : constant Any_Path :=
Den.Filesystem.Relative (Den.Scrub (Parent),
Den.Scrub (Child));
end Find_Relative_Path;

----------------------
Expand Down Expand Up @@ -820,33 +809,32 @@ package body Alire.Directories is
Remove_From_Source : Boolean)
is

Base : constant Absolute_Path := Adirs.Full_Name (Src);
Target : constant Absolute_Path := Adirs.Full_Name (Dst);
Base : constant Absolute_Path := Den.Filesystem.Absolute (Src);
Target : constant Absolute_Path := Den.Filesystem.Absolute (Dst);

-----------
-- Merge --
-----------

procedure Merge
(Item : Ada.Directories.Directory_Entry_Type;
(Item : Any_Path;
Stop : in out Boolean)
is
use all type Adirs.File_Kind;

use all type Den.Kinds;
Src : constant Absolute_Path := Den.Filesystem.Absolute (Item);
Rel_Path : constant Relative_Path :=
Find_Relative_Path (Base, Adirs.Full_Name (Item));
Find_Relative_Path (Base, Src);
-- If this proves to be too slow, we should do our own recursion,
-- building the relative path along the way, as this is recomputing
-- it for every file needlessly.

Dst : constant Absolute_Path := Target / Rel_Path;
Src : constant Absolute_Path := Adirs.Full_Name (Item);
begin
Stop := False;

-- Check if we must skip (we delete source file)

if Adirs.Kind (Item) = Ordinary_File
if Den.Kind (Item) /= Directory
and then Skip_Top_Level_Files
and then Base = Parent (Src)
then
Expand All @@ -856,7 +844,7 @@ package body Alire.Directories is

-- Create a new dir if necessary

if Adirs.Kind (Item) = Directory then
if Den.Kind (Item) = Directory then
if not Is_Directory (Dst) then
Trace.Debug (" Merge: Creating destination dir " & Dst);
Create_Tree (Dst);
Expand All @@ -870,15 +858,15 @@ package body Alire.Directories is
-- Copy file into place

Trace.Debug (" Merge: copying "
& Adirs.Full_Name (Item)
& Den.Filesystem.Absolute (Item)
& " into " & Dst);

if Adirs.Exists (Dst) then
if Den.Exists (Dst) then
if Fail_On_Existing_File then
Recoverable_User_Error ("Cannot copy " & TTY.URL (Src)
& " into place, file already exists: "
& TTY.URL (Dst));
elsif Adirs.Kind (Dst) /= Ordinary_File then
elsif Den.Kind (Dst) /= File then
Raise_Checked_Error ("Cannot overwrite " & TTY.URL (Dst)
& " as it is not a regular file");
else
Expand Down Expand Up @@ -912,7 +900,11 @@ package body Alire.Directories is
exception
when E : others =>
Trace.Error
("When copying " & Src & " --> " & Dst & ": ");
("When copying " & Src & " (" & Den.Kind (Src)'Image
& ") --> " & Dst & ": ");
Trace.Error
("Src item was: "
& Item & " (" & Den.Kind (Item)'Image & ")");
Log_Exception (E, Error);
raise;
end;
Expand Down Expand Up @@ -941,112 +933,60 @@ package body Alire.Directories is

procedure Traverse_Tree (Start : Any_Path;
Doing : access procedure
(Item : Ada.Directories.Directory_Entry_Type;
(Item : Any_Path;
Stop : in out Boolean);
Recurse : Boolean := False;
Spinner : Boolean := False)
is
use Ada.Directories;

Visited : AAA.Strings.Set;
-- To avoid infinite recursion in case of softlinks pointed to parent
-- folders

Progress : Simple_Logging.Ongoing :=
Simple_Logging.Activity (Text => "Exploring " & Start,
Level => (if Spinner
then Info
else Debug));

procedure Go_Down (Item : Directory_Entry_Type);

----------------------------
-- Traverse_Tree_Internal --
----------------------------

procedure Traverse_Tree_Internal
(Start : Any_Path;
Doing : access procedure
(Item : Ada.Directories.Directory_Entry_Type;
Stop : in out Boolean);
Recurse : Boolean := False)
is
pragma Unreferenced (Doing, Recurse);
begin
Search (Start,
"",
(Directory => True, Ordinary_File => True, others => False),
Go_Down'Access);
end Traverse_Tree_Internal;

-------------
-- Go_Down --
-------------

procedure Go_Down (Item : Directory_Entry_Type) is
Stop : Boolean := False;
Prune : Boolean := False;
VF : constant VFS.Virtual_File :=
VFS.New_Virtual_File (VFS.From_FS (Full_Name (Item)));
-- We use this later to check whether this is a soft link
procedure Go_Down (This : Den.Walk.Item;
Enter : in out Boolean;
Stop : in out Boolean)
is
use all type Den.Kinds;
Path : constant Any_Path := This.Path;
begin
Enter := True;
Stop := False;

-- Ada.Directories reports softlinks not as special files but as the
-- target of the link. This confuses users of Traverse_Tree that may
-- see files within a folder that has never been visited before.

-- Short of introducing new file kinds for softlinks and reporting
-- them to clients, for now we just ignore softlinks to dirs, and
-- this way only actual folders are traversed.

if VF.Is_Symbolic_Link and then Kind (Item) = Directory then
Trace.Warning ("Skipping softlink dir during tree traversal: "
& Full_Name (Item));
begin
Doing (This.Path, Stop);
exception
when Traverse_Tree_Prune_Dir =>
Enter := False;
end;
if Stop then
return;
end if;

if Simple_Name (Item) /= "." and then Simple_Name (Item) /= ".." then
begin
Doing (Item, Stop);
exception
when Traverse_Tree_Prune_Dir =>
Prune := True;
end;
if Stop then
return;
end if;

if not Prune and then Recurse and then Kind (Item) = Directory then
declare
Normal_Name : constant Absolute_Path
:=
String (GNATCOLL.VFS.Full_Name
(VFS.New_Virtual_File (Full_Name (Item)),
Normalize => True,
Resolve_Links => True).all);
begin
if Visited.Contains (Normal_Name) then
Trace.Debug ("Not revisiting " & Normal_Name);
else
Visited.Insert (Normal_Name);
if Spinner then
Progress.Step ("Exploring .../" & Simple_Name (Item));
end if;
Traverse_Tree_Internal (Normal_Name, Doing, Recurse);
end if;
end;
elsif Prune and then Kind (Item) = Directory then
Trace.Debug ("Skipping dir: " & Full_Name (Item));
elsif Prune and then Kind (Item) /= Directory then
Trace.Warning ("Pruning of non-dir entry has no effect: "
& Full_Name (Item));
if Enter and then Recurse and then Den.Kind (Path) = Directory then
if Spinner then
Progress.Step ("Exploring .../" & Simple_Name (Path));
end if;
elsif not Enter and then Den.Kind (Path) = Directory then
Trace.Debug ("Skipping dir: " & Full_Name (Path));
elsif not Enter and then Den.Kind (Path) /= Directory then
Trace.Warning ("Pruning of non-dir entry has no effect: "
& Full_Name (Path));
end if;
end Go_Down;

begin
Trace.Debug ("Traversing folder: " & Adirs.Full_Name (Start));
Traverse_Tree_Internal (Start, Doing, Recurse);
Den.Walk.Find (Start,
Action => Go_Down'Access,
Options => (Enter_Regular_Dirs => Recurse, others => <>));
end Traverse_Tree;

---------------
Expand All @@ -1062,7 +1002,7 @@ package body Alire.Directories is
-- Accumulate --
----------------

procedure Accumulate (Item : Directory_Entry_Type;
procedure Accumulate (Item : Any_Path;
Stop : in out Boolean)
is
begin
Expand Down
2 changes: 1 addition & 1 deletion src/alire/alire-directories.ads
View file
Original file line number Diff line number Diff line change
Expand Up @@ -114,7 +114,7 @@ package Alire.Directories is

procedure Traverse_Tree (Start : Any_Path;
Doing : access procedure
(Item : Ada.Directories.Directory_Entry_Type;
(Item : Any_Path;
Stop : in out Boolean);
Recurse : Boolean := False;
Spinner : Boolean := False);
Expand Down
2 changes: 1 addition & 1 deletion src/alire/alire-install.adb
View file
Original file line number Diff line number Diff line change
Expand Up @@ -395,7 +395,7 @@ package body Alire.Install is
Result : Installed_Milestones;

procedure Find
(Item : Ada.Directories.Directory_Entry_Type;
(Item : Any_Path;
Stop : in out Boolean)
is
Name : constant String := Adirs.Simple_Name (Item);
Expand Down
Loading

0 comments on commit 6668490

Please sign in to comment.