From 18a6e5ad19cc14d1c5ff0a21dd50711540ce8f09 Mon Sep 17 00:00:00 2001 From: Alejandro R Mosteo Date: Mon, 23 Aug 2021 10:25:54 +0200 Subject: [PATCH] Improvements to cleanup of temp files (#799) * Clean temporaries in config cache too * Show size of freed temporary files * Track and delete temp files on Ctrl-C * CI fix * Ensure all paths are absolute --- src/alire/alire-directories.adb | 145 +++++++++++++++++++++++++++++--- src/alire/alire-directories.ads | 16 +++- src/alire/alire-shared.adb | 11 +-- src/alr/alr-bootstrap.adb | 3 + src/alr/alr-commands-clean.adb | 27 +++++- 5 files changed, 173 insertions(+), 29 deletions(-) diff --git a/src/alire/alire-directories.adb b/src/alire/alire-directories.adb index 472791e9..e29c2306 100644 --- a/src/alire/alire-directories.adb +++ b/src/alire/alire-directories.adb @@ -12,10 +12,63 @@ with Alire.TTY; with GNATCOLL.VFS; +with SI_Units.Binary; + package body Alire.Directories is package Adirs renames Ada.Directories; + ------------------- + -- Temp_Registry -- + ------------------- + -- To be able to remove temp files when we are forcibly interrupted, we + -- keep track of them here. Calling Delete_Temporaries will do the cleanup + -- (as file ops are blocking and cannot be done in a protected). + protected Temp_Registry is + + procedure Add (Path : Absolute_Path); + -- Add a path to a temporary + + procedure Del (Path : Absolute_Path); + -- Remove a path to a temporary + + function Get return Utils.String_Set; + -- Retrieve all current temporaries + + private + + Registry : Utils.String_Set; + + end Temp_Registry; + + protected body Temp_Registry is + + --------- + -- Add -- + --------- + + procedure Add (Path : Absolute_Path) is + begin + Registry.Include (Path); + end Add; + + --------- + -- Del -- + --------- + + procedure Del (Path : Absolute_Path) is + begin + Registry.Exclude (Path); + end Del; + + --------- + -- Get -- + --------- + + function Get return Utils.String_Set is (Registry); + + end Temp_Registry; + ------------------------ -- Backup_If_Existing -- ------------------------ @@ -88,6 +141,33 @@ package body Alire.Directories is Make_Dir (Create (+Path)); end Create_Tree; + ------------------------ + -- Delete_Temporaries -- + ------------------------ + + procedure Delete_Temporaries is + Paths : constant Utils.String_Set := Temp_Registry.Get; + begin + if Paths.Is_Empty then + Trace.Debug ("No temporaries to remove"); + else + for Path of Paths loop + begin + Force_Delete (Path); + exception + when E : others => + Trace.Debug ("Could not delete temporary " & Path & ": " + & Errors.Get (E)); + Log_Exception (E); + + -- As this is used during final cleanup, any exception here + -- is logged but not raised. Maybe this can happen for open + -- files? + end; + end loop; + end if; + end Delete_Temporaries; + ----------------- -- Delete_Tree -- ----------------- @@ -370,9 +450,8 @@ package body Alire.Directories is overriding procedure Initialize (This : in out Temp_File) is - + Simple_Name : constant String := Temp_Name; begin - This.Name := +Temp_Name; -- Try to use our alire folder to hide temporaries; return an absolute -- path in any case to avoid problems with the user of the tmp file @@ -394,20 +473,22 @@ package body Alire.Directories is This.Name := +Ada.Directories.Full_Name (Paths.Working_Folder_Inside_Root / Paths.Temp_Folder_Inside_Working_Folder - / (+This.Name)); + / Simple_Name); else - This.Name := +Ada.Directories.Full_Name (+This.Name); + This.Name := +Ada.Directories.Full_Name (Simple_Name); end if; + + Temp_Registry.Add (+This.Name); end Initialize; -------------- -- Filename -- -------------- - function Filename (This : Temp_File) return String is + function Filename (This : Temp_File) return Absolute_Path is (+This.Name); ---------- @@ -417,6 +498,7 @@ package body Alire.Directories is procedure Keep (This : in out Temp_File) is begin This.Keep := True; + Temp_Registry.Del (+This.Name); end Keep; -------------- @@ -431,6 +513,9 @@ package body Alire.Directories is return; end if; + -- We are deleting it here, so remove from "live" temp files registry + Temp_Registry.Del (+This.Name); + -- Force writability of folder when in Windows, as some tools (e.g. git) -- that create read-only files will cause a Use_Error @@ -521,20 +606,54 @@ package body Alire.Directories is end Accumulate; begin - Traverse_Tree (Path, - Doing => Accumulate'Access, - Recurse => True); - return Result; + if not Ada.Directories.Exists (Path) then + return 0; + end if; + + case Ada.Directories.Kind (Path) is + when Ordinary_File => + return Ada.Directories.Size (Path); + + when Directory => + Traverse_Tree (Path, + Doing => Accumulate'Access, + Recurse => True); + return Result; + + when others => + return 0; + end case; end Tree_Size; + --------------- + -- TTY_Image -- + --------------- + + function TTY_Image (Size : Ada.Directories.File_Size) return String is + type Modular_File_Size is mod 2 ** Ada.Directories.File_Size'Size; + + function Image is new SI_Units.Binary.Image + (Item => Modular_File_Size, + Default_Aft => 1, + Unit => "B"); + begin + return TTY.Emph (Image (Modular_File_Size (Size))); + end TTY_Image; + --------------- -- With_Name -- --------------- - function With_Name (Name : String) return Temp_File is - (Temp_File'(Ada.Finalization.Limited_Controlled with - Keep => <>, - Name => +Name)); + function With_Name (Name : Any_Path) return Temp_File is + begin + return Temp : constant Temp_File := + (Temp_File'(Ada.Finalization.Limited_Controlled with + Keep => <>, + Name => +Adirs.Full_Name (Name))) + do + Temp_Registry.Add (+Temp.Name); + end return; + end With_Name; -------------- -- REPLACER -- diff --git a/src/alire/alire-directories.ads b/src/alire/alire-directories.ads index 38f04c01..9989a2b0 100644 --- a/src/alire/alire-directories.ads +++ b/src/alire/alire-directories.ads @@ -82,7 +82,11 @@ package Alire.Directories is -- ignored. If Stop is set to True, traversal will not continue. function Tree_Size (Path : Any_Path) return Ada.Directories.File_Size; - -- Size of files under a given point, in bytes. + -- Size of files under a given point, in bytes. Will return 0 for an + -- invalid path or an special file. + + function TTY_Image (Size : Ada.Directories.File_Size) return String; + -- Obtain a human-readable and colorized representation of a file size ---------------- -- GUARD TYPE -- @@ -107,6 +111,10 @@ package Alire.Directories is -- Temporary files -- --------------------- + procedure Delete_Temporaries; + -- For user forced Ctrl-C interruptions, this will attempt to delete any + -- currently existing temporaries. + function Temp_Name (Length : Positive := 8) return String with Pre => Length >= 5; -- Return a filename such as "alr-sdrv.tmp". Length refers to the name @@ -121,7 +129,7 @@ package Alire.Directories is -- The file is deleted once an object of this type goes out of scope. -- If the file/folder was never created on disk nothing will happen. - function Filename (This : Temp_File) return String; + function Filename (This : Temp_File) return Absolute_Path; -- The filename is a random sequence of 8 characters + ".tmp" procedure Keep (This : in out Temp_File); @@ -129,7 +137,7 @@ package Alire.Directories is -- allows creating a temporary that will be deleted in case of failure but -- kept in case of success. - function With_Name (Name : String) return Temp_File; + function With_Name (Name : Any_Path) return Temp_File; -- Allows initializing the tmp file with a desired name. -- REPLACER: Modify a file "in place" in a safe way (keeping old copy) @@ -180,7 +188,7 @@ private type Temp_File is new Ada.Finalization.Limited_Controlled with record Keep : Boolean := False; - Name : UString; + Name : Unbounded_Absolute_Path; end record; overriding diff --git a/src/alire/alire-shared.adb b/src/alire/alire-shared.adb index f422174b..4a829972 100644 --- a/src/alire/alire-shared.adb +++ b/src/alire/alire-shared.adb @@ -13,8 +13,6 @@ with Alire.Toolchains.Solutions; with Alire.TTY; with Alire.Warnings; -with SI_Units.Binary; - package body Alire.Shared is use Directories.Operators; @@ -193,13 +191,6 @@ package body Alire.Shared is (Release : Releases.Release; Confirm : Boolean := not Utils.User_Input.Not_Interactive) is - type Modular_File_Size is mod 2 ** Ada.Directories.File_Size'Size; - - function Image is new SI_Units.Binary.Image - (Item => Modular_File_Size, - Default_Aft => 1, - Unit => "B"); - use Utils.User_Input; Path : constant Absolute_Path := Install_Path / Release.Unique_Folder; begin @@ -229,7 +220,7 @@ package body Alire.Shared is if not Confirm or else Utils.User_Input.Query (Question => "Release " & Release.Milestone.TTY_Image & " is going to " & "be removed, freeing " - & TTY.Emph (Image (Modular_File_Size (Directories.Tree_Size (Path)))) + & Directories.TTY_Image (Directories.Tree_Size (Path)) & ". Do you want to proceed?", Valid => (No | Yes => True, others => False), Default => Yes) = Yes diff --git a/src/alr/alr-bootstrap.adb b/src/alr/alr-bootstrap.adb index 7ec72bdb..67b724e4 100644 --- a/src/alr/alr-bootstrap.adb +++ b/src/alr/alr-bootstrap.adb @@ -1,5 +1,6 @@ with Ada.Calendar; +with Alire.Directories; with Alire_Early_Elaboration; with Alire.Index; with Alire.Root; @@ -19,6 +20,8 @@ package body Alr.Bootstrap is begin Trace.Always (" Interrupted by user"); + Alire.Directories.Delete_Temporaries; + OS_Lib.Bailout (1); end Interrupted; diff --git a/src/alr/alr-commands-clean.adb b/src/alr/alr-commands-clean.adb index 6cf5c275..12986806 100644 --- a/src/alr/alr-commands-clean.adb +++ b/src/alr/alr-commands-clean.adb @@ -1,5 +1,6 @@ with Ada.Directories; +with Alire.Config.Edit; with Alire.Directories; with Alire.Paths; with Alire.TTY; @@ -16,14 +17,25 @@ package body Alr.Commands.Clean is procedure Delete_Temp_Files is + Freed : Ada.Directories.File_Size := 0; + + ----------------- + -- Freed_Image -- + ----------------- + + function Freed_Image return String + is ("freeing " & Alire.Directories.TTY_Image (Freed) & "."); + ------------ -- Delete -- ------------ procedure Delete (Path : String) is + use type Ada.Directories.File_Size; begin Trace.Detail ("Deleting " & Alire.TTY.URL (Path)); + Freed := Freed + Alire.Directories.Tree_Size (Path); Alire.Directories.Force_Delete (Path); end Delete; @@ -47,11 +59,21 @@ package body Alr.Commands.Clean is package TTY renames Alire.TTY; begin + + -- Current workspace + Alire.Directories.Traverse_Tree (Start => ".", Doing => Add_Target'Access, Recurse => True); + -- Configuration-wide cache, where interrupted binary downloads dwell... + + Alire.Directories.Traverse_Tree + (Start => Alire.Config.Edit.Path, + Doing => Add_Target'Access, + Recurse => True); + for Target of Targets loop Delete (Target); end loop; @@ -59,10 +81,11 @@ package body Alr.Commands.Clean is if Targets.Is_Empty then Trace.Info ("No temporaries found."); elsif Targets.Length in 1 then - Trace.Info ("Deleted " & TTY.Emph ("1") & " temporary."); + Trace.Info ("Deleted " & TTY.Emph ("1") & " temporary, " + & Freed_Image); else Trace.Info ("Deleted" & TTY.Emph (Targets.Length'Image) - & " temporaries."); + & " temporaries, " & Freed_Image); end if; end Delete_Temp_Files; -- 2.39.5