devel/ahven: Improve symbolic traceback functionality

Rather than show the lengthy and not helpful trace of the Ahven
Framework when a symbolic trace is shown, detect the start of this
infrastructure trace and truncate it there.  This helps debugging
greatly by removing a lot of noise.

2 files changed, 31 insertions, 6 deletions

diff --git a/devel/ahven/Makefile b/devel/ahven/Makefile
index d81e5f0309e8..e2befb1ab1d1 100644
--- a/devel/ahven/Makefile
+++ b/devel/ahven/Makefile
@@ -3,7 +3,7 @@
 
 PORTNAME=	ahven
 PORTVERSION=	2.4
-PORTREVISION=	3
+PORTREVISION=	4
 CATEGORIES=	devel
 MASTER_SITES=	SF
 MASTER_SITE_SUBDIR=${PORTNAME}/${PORTNAME}/Ahven%20${PORTVERSION}
diff --git a/devel/ahven/files/extra-src_ahven-framework.adb b/devel/ahven/files/extra-src_ahven-framework.adb
index b80adf17d2bc..a25d65d0620f 100644
--- a/devel/ahven/files/extra-src_ahven-framework.adb
+++ b/devel/ahven/files/extra-src_ahven-framework.adb
@@ -5,30 +5,55 @@
  --
  
 +with GNAT.Traceback.Symbolic;
-+use  GNAT.Traceback.Symbolic;
++with GNAT.Regpat;
  with Ada.Strings;
  with Ada.Unchecked_Deallocation;
  with Ada.Exceptions;
-@@ -346,19 +348,19 @@ package body Ahven.Framework is
+@@ -22,6 +24,24 @@ with Ahven.Long_AStrings;
+ package body Ahven.Framework is
+    use Ahven.AStrings;
+ 
++   -- Convert an exception into a traceback, but truncate it at the first
++   -- line matching "0x.* in ahven.framework" as this is unwanted trace.
++   function Filtered_Traceback (E : in Ada.Exceptions.Exception_Occurrence)
++   return String is
++      ftb : constant String := GNAT.Traceback.Symbolic.Symbolic_Traceback (E);
++      pat : constant String := "(0x[0-9a-f]* in ahven\.framework)";
++      reg : constant GNAT.Regpat.Pattern_Matcher := GNAT.Regpat.Compile (pat);
++      result : GNAT.Regpat.Match_Array (0 .. 1);
++      use type GNAT.Regpat.Match_Location;
++   begin
++      GNAT.Regpat.Match (reg, ftb, result);
++      if result (0) = GNAT.Regpat.No_Match then
++         return ftb;
++      else
++         return ftb (1 .. result (1).First - 2);
++      end if;
++   end Filtered_Traceback;
++
+    -- A few local procedures, so we do not need to duplicate code.
+    procedure Free_Test is
+       new Ada.Unchecked_Deallocation (Object => Test'Class,
+@@ -346,19 +366,19 @@ package body Ahven.Framework is
                 Set_Status
                   (S            => TEST_FAIL,
                    Message      => Ada.Exceptions.Exception_Message (E),
 -                  Long_Message => Ada.Exceptions.Exception_Information (E),
-+                  Long_Message => Symbolic_Traceback (E),
++                  Long_Message => Filtered_Traceback (E),
                    R            => Result);
              when E : Test_Skipped_Error =>
                 Set_Status
                   (S            => TEST_SKIP,
                    Message      => Ada.Exceptions.Exception_Message (E),
 -                  Long_Message => Ada.Exceptions.Exception_Information (E),
-+                  Long_Message => Symbolic_Traceback (E),
++                  Long_Message => Filtered_Traceback (E),
                    R            => Result);
              when E : others =>
                 Set_Status
                   (S            => TEST_ERROR,
                    Message      => Ada.Exceptions.Exception_Message (E),
 -                  Long_Message => Ada.Exceptions.Exception_Information (E),
-+                  Long_Message => Symbolic_Traceback (E),
++                  Long_Message => Filtered_Traceback (E),
                    R            => Result);
           end;
        end Run_A_Command;