Make sure error messages from Finalization are displayed to the user (a…

…lire-project#1580)

scripts/ci-github.sh

@@ -72,6 +72,10 @@ $run_pip install --upgrade -r requirements.txt
 echo Python search paths:
 $run_python -c "import sys; print('\n'.join(sys.path))"
 
+echo Check Finalize exception handling :
+$run_python ../scripts/python/check_finalize_exceptions.py ../src
+echo ............................
+
 echo Running test suite now:
 $run_python ./run.py -E || { echo Test suite failures, unstable build!; exit 1; }
 cd ..

scripts/python/check_finalize_exceptions.py

@@ -0,0 +1,40 @@
+#!/usr/bin/env python3
+# Find all Finalize procedures that do not report unhandled exceptions
+
+import re
+import glob
+import sys
+
+
+def find_matching(source_file, match_pattern, exclude_pattern):
+    match_re = re.compile(match_pattern)
+    exclude_re = re.compile(exclude_pattern)
+
+    count = 0
+    with open(source_file, "r", encoding="utf-8") as file:
+        previous_line = ""
+        line_nbr = 1
+        for line in file:
+            if match_re.search(line) and not exclude_re.search(previous_line):
+                print(f"{source_file}:{line_nbr}: " + line)
+                count = count + 1
+            previous_line = line
+            line_nbr = line_nbr + 1
+
+    return count > 0
+
+
+if __name__ == "__main__":
+    if len(sys.argv) != 2:
+        print("Please provide one directory path")
+        sys.exit(1)
+
+    count = 0
+    for file in glob.glob(f"{sys.argv[1]}/**/*.ad[bs]"):
+        if find_matching(
+            file, ".*end Finalize;.*", ".*Alire.Utils.Finalize_Exception.*"
+        ):
+            count = count + 1
+
+    if count > 0:
+        sys.exit(1)

src/alire/alire-directories.adb

@@ -1,6 +1,5 @@
 with AAA.Directories;
 
-with Ada.Exceptions;
 with Ada.Numerics.Discrete_Random;
 with Ada.Real_Time;
 with Ada.Unchecked_Conversion;
@@ -11,6 +10,7 @@ with Alire.Paths;
 with Alire.Platforms.Current;
 with Alire.Platforms.Folders;
 with Alire.VFS;
+with Alire.Utils;
 
 with GNAT.String_Hash;
 
@@ -490,7 +490,6 @@ package body Alire.Directories is
    overriding
    procedure Finalize (This : in out Guard) is
       use Ada.Directories;
-      use Ada.Exceptions;
       use Ada.Strings.Unbounded;
       procedure Free is
         new Ada.Unchecked_Deallocation (Absolute_Path, Destination);
@@ -506,10 +505,7 @@ package body Alire.Directories is
       Free (Freeable);
    exception
       when E : others =>
-         Trace.Debug
-           ("FG.Finalize: unexpected exception: " &
-              Exception_Name (E) & ": " & Exception_Message (E) & " -- " &
-              Exception_Information (E));
+         Alire.Utils.Finalize_Exception (E);
    end Finalize;
 
    ------------------
@@ -760,8 +756,7 @@ package body Alire.Directories is
 
    exception
       when E : others =>
-         Log_Exception (E);
-         raise;
+         Alire.Utils.Finalize_Exception (E);
    end Finalize;
 
    --------------------

src/alire/alire-errors.adb

@@ -1,4 +1,5 @@
 with Ada.Containers.Indefinite_Ordered_Maps;
+with Alire.Utils;
 
 package body Alire.Errors is
 
@@ -209,6 +210,9 @@ package body Alire.Errors is
       pragma Unreferenced (This);
    begin
       Close;
+   exception
+      when E : others =>
+         Alire.Utils.Finalize_Exception (E);
    end Finalize;
 
    -----------

src/alire/alire-roots-editable.adb

@@ -523,14 +523,17 @@ package body Alire.Roots.Editable is
                Trace.Debug ("Discarding temporary root file: " & File);
             end;
          end if;
+      exception
+         when E : others =>
+            Alire.Utils.Finalize_Exception (E);
       end Finalize;
 
    begin
       Finalize (+This.Edit.Manifest);
       Finalize (+This.Edit.Lockfile);
    exception
       when E : others =>
-         Log_Exception (E, Warning);
+         Alire.Utils.Finalize_Exception (E);
    end Finalize;
 
    ---------

src/alire/alire-roots.adb

@@ -2067,6 +2067,9 @@ package body Alire.Roots is
         (Crate_Configuration.Global_Config, Global_Config_Access);
    begin
       Free (This.Configuration);
+   exception
+      when E : others =>
+         Alire.Utils.Finalize_Exception (E);
    end Finalize;
 
 end Alire.Roots;

src/alire/alire-toml_adapters.adb

@@ -1,3 +1,5 @@
+with Alire.Utils;
+
 package body Alire.TOML_Adapters is
 
    --------------
@@ -10,6 +12,10 @@ package body Alire.TOML_Adapters is
    begin
       --  Manually close this error scope
       Errors.Close;
+
+   exception
+      when E : others =>
+         Alire.Utils.Finalize_Exception (E);
    end Finalize;
 
    ------------

src/alire/alire-utils-text_files.adb

@@ -46,6 +46,10 @@ package body Alire.Utils.Text_Files is
          Close (File);
          Replacer.Replace;
       end;
+
+   exception
+      when E : others =>
+         Alire.Utils.Finalize_Exception (E);
    end Finalize;
 
    -----------

src/alire/alire-utils.adb

@@ -253,4 +253,23 @@ package body Alire.Utils is
       end if;
    end Image_Keys_One_Line;
 
+   ------------------------
+   -- Finalize_Exception --
+   ------------------------
+
+   procedure Finalize_Exception (E : Ada.Exceptions.Exception_Occurrence) is
+
+      --  Import a Last_Chance_Handler procedure that will either be the one
+      --  declared by Alr, or the default GNAT last chance handler.
+
+      procedure Last_Chance_Handler (E : Ada.Exceptions.Exception_Occurrence);
+      pragma Import (C,
+                     Last_Chance_Handler,
+                     "__gnat_last_chance_handler");
+      pragma No_Return (Last_Chance_Handler);
+
+   begin
+      Last_Chance_Handler (E);
+   end Finalize_Exception;
+
 end Alire.Utils;

src/alire/alire-utils.ads

@@ -84,6 +84,27 @@ package Alire.Utils with Preelaborate is
    --  Flatten String keys of Indefinite_Ordered_Maps into string
    --  representation.
 
+   procedure Finalize_Exception (E : Ada.Exceptions.Exception_Occurrence);
+   --  Every controlled object Finalize procedure must call this function to
+   --  report unhandled exceptions.
+   --
+   --  Ada exceptions are not propagated outside the Finalize procedure.
+   --  Instead, another exception is raise with the message "finalize/adjust
+   --  raised exception". Alire is using exceptions to report meaningfull error
+   --  messages to the user. If one of these exception is raised in a Finalize
+   --  procedure, the error message will vanish and the user will only see
+   --  "finalize/adjust raised exception".
+   --
+   --  For this reason, it is important to catch all exceptions before reaching
+   --  the end of Finalize and use this Finalize_Exception procedure to display
+   --  a meaningful error message.
+   --
+   --  Use the following code at the end of every Finalize procedures:
+   --   exception
+   --      when E : others =>
+   --         Alire.Utils.Finalize_Exception (E);
+   --   end Finalize;
+
 private
 
    function Quote (S : String) return String

src/alr/alr-commands-dev.adb

@@ -1,6 +1,8 @@
 with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;
+with Ada.Finalization;
 
 with Alire.Selftest;
+with Alire.Utils;
 
 package body Alr.Commands.Dev is
 
@@ -24,6 +26,28 @@ package body Alr.Commands.Dev is
       Trace.Always (Encode ("ⓘ✓"));
    end Print_UTF_8_Sequence;
 
+   -----------------------------
+   -- Raise_From_Finalization --
+   -----------------------------
+
+   procedure Raise_From_Finalization is
+      type Ctrl is new Ada.Finalization.Controlled with null record;
+
+      overriding
+      procedure Finalize (This : in out Ctrl) is
+      begin
+         raise Program_Error with "Raising forcibly from finalization";
+      exception
+         when E : others =>
+            Alire.Utils.Finalize_Exception (E);
+      end Finalize;
+
+      Test : Ctrl;
+      pragma Unreferenced (Test);
+   begin
+      null;
+   end Raise_From_Finalization;
+
    -------------
    -- Execute --
    -------------
@@ -49,6 +73,10 @@ package body Alr.Commands.Dev is
          raise Program_Error with "Raising forcibly";
       end if;
 
+      if Cmd.Raise_Final then
+         Raise_From_Finalization;
+      end if;
+
       if Cmd.Self_Test then
          Alire.Selftest.Run;
       end if;
@@ -96,6 +124,11 @@ package body Alr.Commands.Dev is
                      "", "--raise",
                      "Raise an exception");
 
+      Define_Switch (Config,
+                     Cmd.Raise_Final'Access,
+                     "", "--raise-finalization",
+                     "Raise an exception from a finalization procedure");
+
       Define_Switch (Config,
                      Cmd.Self_Test'Access,
                      "", "--test",

src/alr/alr-commands-dev.ads

@@ -35,6 +35,7 @@ private
       Custom       : aliased Boolean := False; -- Custom code to run instead
       Filtering    : aliased Boolean := False; -- Runs debug scope filtering
       Raise_Except : aliased Boolean := False;
+      Raise_Final  : aliased Boolean := False;
       Self_Test    : aliased Boolean := False;
       UTF_8_Test   : aliased Boolean := False; -- Produce some UTF-8 output
    end record;

src/alr/alr-utils-temp_file.adb

@@ -14,6 +14,10 @@ package body Alr.Utils.Temp_File is
          Delete_File (This.Name);
          null;
       end if;
+
+   exception
+      when E : others =>
+         Alire.Utils.Finalize_Exception (E);
    end Finalize;
 
    --------------

testsuite/tests/debug/enabled-dump-exception/test.py

@@ -28,4 +28,9 @@ def check_output(dump):
           "ERROR: Raising forcibly\n"
           "ERROR: alr encountered an unexpected error, re-run with -d for details.\n")
 
+# Check exception from finalization :
+assert_eq(run_alr('dev', '--raise-finalization', debug=False, complain_on_error=False).out,
+          "ERROR: Raising forcibly from finalization\n"
+          "ERROR: alr encountered an unexpected error, re-run with -d for details.\n")
+
 print('SUCCESS')