From feb36c66a47322a09ceb7291f80a1f08492ed97e Mon Sep 17 00:00:00 2001 From: Tama McGlinn Date: Wed, 13 May 2020 14:10:43 +0200 Subject: [PATCH 1/5] Added TRX reporter which generates unit test report that vNext TFS build system can display graphically removed finalization from aunit reporter fixed Report signature; Result is no longer in out Added copyright notice to trx reporter break all lines over 80 characters, except the url use Engine.File rather than hardcoded testresult.trx --- .../aunit/reporters/aunit-reporter-trx.adb | 318 ++++++++++++++++++ .../aunit/reporters/aunit-reporter-trx.ads | 42 +++ 2 files changed, 360 insertions(+) create mode 100644 include/aunit/reporters/aunit-reporter-trx.adb create mode 100644 include/aunit/reporters/aunit-reporter-trx.ads diff --git a/include/aunit/reporters/aunit-reporter-trx.adb b/include/aunit/reporters/aunit-reporter-trx.adb new file mode 100644 index 0000000..53f86d4 --- /dev/null +++ b/include/aunit/reporters/aunit-reporter-trx.adb @@ -0,0 +1,318 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A U N I T . R E P O R T E R . T R X -- +-- -- +-- B o d y -- +-- -- +-- -- +-- Copyright (C) 2000-2020, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT is maintained by AdaCore (http://www.adacore.com) -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; +with Ada.Text_IO; +with Ada.Strings.Unbounded; +with Ada.Containers.Vectors; +with Ada_Containers; + +package body AUnit.Reporter.TRX is + + procedure Put_Line (File : Ada.Text_IO.File_Type; S : String) + renames Ada.Text_IO.Put_Line; + + package SU renames Ada.Strings.Unbounded; + + type Test_Outcome is (Passed, Failed, Error); + + function Outcome_Str (Outcome : Test_Outcome) return String is + begin + return (case Outcome is + when Passed => "Passed", + when Failed => "Failed", + when Error => "Failed"); + end Outcome_Str; + + type Test_Data is record + Name : SU.Unbounded_String; + Outcome : Test_Outcome; + Duration : SU.Unbounded_String; + Routine_Name : SU.Unbounded_String; + -- for assertion failures + Failure_Message : SU.Unbounded_String; + Failure_Source_Name : SU.Unbounded_String; + Line : SU.Unbounded_String; + -- for exceptions + Exception_Name : SU.Unbounded_String; + Exception_Message : SU.Unbounded_String; + Backtrace : SU.Unbounded_String; + end record; + + function Get_Test_Data (Test : Test_Result) return Test_Data; + + package Test_Data_Vecs is new Ada.Containers.Vectors + (Element_Type => Test_Data, + Index_Type => Positive); + + procedure Iterate + (Container : Test_Data_Vecs.Vector; + Process : not null access procedure (Position : Test_Data_Vecs.Cursor)) + renames Test_Data_Vecs.Iterate; + + function Get_All_Results (R : Result'Class) + return Test_Data_Vecs.Vector is + All_Results : Test_Data_Vecs.Vector; + F, E, S : Result_Lists.List; + + procedure Get_Result_List (L : Result_Lists.List) is + use Result_Lists; + C : Cursor := First (L); + begin + -- Note: can't use Iterate because it violates restriction + -- No_Implicit_Dynamic_Code + while Has_Element (C) loop + All_Results.Append (Get_Test_Data (Element (C))); + Next (C); + end loop; + end Get_Result_List; + + begin + Failures (R, F); + Errors (R, E); + Successes (R, S); + Get_Result_List (F); + Get_Result_List (E); + Get_Result_List (S); + return All_Results; + end Get_All_Results; + + procedure Report (Engine : TRX_Reporter; + R : Result'Class; + Options : AUnit_Options := Default_Options) + is + pragma Unreferenced (Options); + + File : Ada.Text_IO.File_Type renames Engine.File.all; + + use type Ada_Containers.Count_Type; + Total : constant Ada_Containers.Count_Type := Test_Count (R); + Failures : constant Ada_Containers.Count_Type := Failure_Count (R) + + Error_Count (R); + Successes : constant Ada_Containers.Count_Type := Total - Failures; + + function Str(I : Ada_Containers.Count_Type) return String is + S : constant String := I'Image; + begin + return S(2..S'Last); -- remove leading space + end Str; + + procedure Report_Test_Name (Test_Cursor : Test_Data_Vecs.Cursor) is + Test : constant Test_Data := Test_Data_Vecs.Element (Test_Cursor); + begin + Put_Line (File, " "); + end Report_Test_Name; + + -- I found this example trx file + -- https://github.com/x97mdr/pickles/blob/master/src/Pickles/Pickles.Test/results-example-mstest.trx + -- it says UnitTestResult can have StdOut (text) and ErrorInfo + -- containing Message and StackTrace + procedure Report_Test (Test_Cursor : Test_Data_Vecs.Cursor) is + Test : constant Test_Data := Test_Data_Vecs.Element (Test_Cursor); + begin + Put_Line (File, " "); + if Test.Outcome /= Passed then + Put_Line (File, " "); + Put_Line (File, " "); + Put_Line (File, " "); + if Test.Outcome = Failed then + Put_Line (File, "Assertion failed on line" + & SU.To_String (Test.Line) + & " of " & SU.To_String (Test.Failure_Source_Name) + & ": """ & SU.To_String (Test.Failure_Message) & """"); + else + Put_Line (File, "Raised " & SU.To_String (Test.Exception_Name) + & ":"); + Put_Line (File, "Exception message:"); + Put_Line (File, SU.To_String (Test.Exception_Message)); + end if; + Put_Line (File, " "); + if Test.Outcome = Error then + Put_Line (File, " "); + Put_Line (File, SU.To_String (Test.Backtrace)); + Put_Line (File, " "); + end if; + Put_Line (File, " "); + Put_Line (File, " "); + end if; + Put_Line (File, " "); + end Report_Test; + begin -- Report + Put_Line (File, ""); + Put_Line (File, ""); + Put_Line (File, " "); + Put_Line (File, " "); + Put_Line (File, " "); + + declare + Tests : constant Test_Data_Vecs.Vector := Get_All_Results (R); + begin + Put_Line (File, " "); + Iterate (Tests, Report_Test_Name'Access); + Put_Line (File, " "); + + Put_Line (File, " "); + Iterate (Tests, Report_Test'Access); + Put_Line (File, " "); + end; + + Put_Line (File, ""); + end Report; + + function Get_Name (Test : Test_Result) return SU.Unbounded_String is + begin + return SU.To_Unbounded_String (Test.Test_Name.all); + end Get_Name; + + function Get_Outcome (Test : Test_Result) return Test_Outcome is + begin + if Test.Error /= null then + return Error; + end if; + if Test.Failure /= null then + return Failed; + end if; + return Passed; + end Get_Outcome; + + function Get_Duration (Test : Test_Result) return SU.Unbounded_String is + use type Ada.Calendar.Time; + Elapsed_Seconds : Duration := Test.Elapsed.Stop - Test.Elapsed.Start; + H, M, S : Integer := 0; + + -- pad integer with leading zero to width 2 + function Str(I : Integer) return String is + S : constant String := I'Image; + S2 : String renames S(S'First + 1 .. S'Last); + begin + if I < 10 then + return "0" & S2; + else + return S2; + end if; + end Str; + + function DecStr(D : Duration) return String is + S : constant String := D'Image; + begin + return S(S'First + 3 .. S'Last); + end DecStr; + begin + H := Integer (Elapsed_Seconds / 3600.0); + Elapsed_Seconds := Elapsed_Seconds - (H * 3600.0); + M := Integer (Elapsed_Seconds / 60.0); + Elapsed_Seconds := Elapsed_Seconds - (M * 60.0); + S := Integer (Elapsed_Seconds / 1.0); + Elapsed_Seconds := Elapsed_Seconds - (S * 1.0); + return SU.To_Unbounded_String (Str (H) & ":" & Str (M) & ":" & Str (S) + & "." & DecStr (Elapsed_Seconds)); + end Get_Duration; + + function Get_Routine_Name (Test : Test_Result) return SU.Unbounded_String is + begin + return (if Test.Routine_Name = null + then SU.To_Unbounded_String ("") + else SU.To_Unbounded_String (Test.Routine_Name.all)); + end Get_Routine_Name; + + function Get_Failure_Message (Test : Test_Result) + return SU.Unbounded_String is + begin + return (if Test.Failure = null + then SU.To_Unbounded_String ("") + else SU.To_Unbounded_String (Test.Failure.Message.all)); + end Get_Failure_Message; + + function Get_Failure_Source_Name (Test : Test_Result) + return SU.Unbounded_String is + begin + return (if Test.Failure = null + then SU.To_Unbounded_String ("") + else SU.To_Unbounded_String (Test.Failure.Source_Name.all)); + end Get_Failure_Source_Name; + + function Get_Line (Test : Test_Result) return SU.Unbounded_String is + begin + return (if Test.Failure = null + then SU.To_Unbounded_String ("") + else SU.To_Unbounded_String (Test.Failure.Line'Image)); + end Get_Line; + + function Get_Exception_Name (Test : Test_Result) + return SU.Unbounded_String is + begin + return (if Test.Error = null + then SU.To_Unbounded_String ("") + else SU.To_Unbounded_String (Test.Error.Exception_Name.all)); + end Get_Exception_Name; + + function Get_Exception_Message (Test : Test_Result) + return SU.Unbounded_String is + begin + return (if Test.Error = null then SU.To_Unbounded_String ("") else + (if Test.Error.Exception_message = null + then SU.To_Unbounded_String ("") + else + SU.To_Unbounded_String (Test.Error.Exception_Message.all))); + end Get_Exception_Message; + + function Get_Backtrace (Test : Test_Result) return SU.Unbounded_String is + begin + return (if Test.Error = null then SU.To_Unbounded_String ("") else + (if Test.Error.Traceback = null + then SU.To_Unbounded_String ("") + else SU.To_Unbounded_String (Test.Error.Traceback.all))); + end Get_Backtrace; + + function Get_Test_Data (Test : Test_Result) return Test_Data is + begin + return (Name => Get_Name (Test), + Outcome => Get_Outcome (Test), + Duration => Get_Duration (Test), + Routine_Name => Get_Routine_Name (Test), + Failure_Message => Get_Failure_Message (Test), + Failure_Source_Name => Get_Failure_Source_Name (Test), + Line => Get_Line (Test), + Exception_Name => Get_Exception_Name (Test), + Exception_Message => Get_Exception_Message (Test), + Backtrace => Get_Backtrace (Test) + ); + end Get_Test_Data; + +end AUnit.Reporter.TRX; diff --git a/include/aunit/reporters/aunit-reporter-trx.ads b/include/aunit/reporters/aunit-reporter-trx.ads new file mode 100644 index 0000000..24a3a67 --- /dev/null +++ b/include/aunit/reporters/aunit-reporter-trx.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A U N I T . R E P O R T E R . T R X -- +-- -- +-- S p e c -- +-- -- +-- -- +-- Copyright (C) 2000-2020, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT is maintained by AdaCore (http://www.adacore.com) -- +-- -- +------------------------------------------------------------------------------ + +package AUnit.Reporter.TRX is + + type TRX_Reporter is new AUnit.Reporter.Reporter with null record; + + overriding + procedure Report + (Engine : TRX_Reporter; + R : Result'Class; + Options : AUnit_Options := Default_Options); + +end AUnit.Reporter.TRX; From 161901107d1213d5a802093a6fccb9175e296578 Mon Sep 17 00:00:00 2001 From: Tama McGlinn Date: Tue, 9 Mar 2021 21:21:54 +0100 Subject: [PATCH 2/5] Fixed typo 'docs' in Makefile clean target --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index ad21034..f3892a7 100644 --- a/Makefile +++ b/Makefile @@ -36,7 +36,7 @@ clean-lib: $(RM) -fr lib/aunit lib/aunit-obj clean: clean-lib - -${MAKE} -C docs clean + -${MAKE} -C doc clean install-clean-legacy: ifneq (,$(wildcard $(INSTALL)/lib/gnat/manifests/aunit)) From 9ec4e860430d28b0ea56970b06eeb685f8c4cec9 Mon Sep 17 00:00:00 2001 From: Tama McGlinn Date: Tue, 9 Mar 2021 21:55:18 +0100 Subject: [PATCH 3/5] Fixed in out mode for Result It was decided in TB02-012 that, even though out is now unused, we should keep it to remain compatible with other client's custom reporters. --- include/aunit/reporters/aunit-reporter-trx.adb | 2 +- include/aunit/reporters/aunit-reporter-trx.ads | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/include/aunit/reporters/aunit-reporter-trx.adb b/include/aunit/reporters/aunit-reporter-trx.adb index 53f86d4..72b2382 100644 --- a/include/aunit/reporters/aunit-reporter-trx.adb +++ b/include/aunit/reporters/aunit-reporter-trx.adb @@ -106,7 +106,7 @@ package body AUnit.Reporter.TRX is end Get_All_Results; procedure Report (Engine : TRX_Reporter; - R : Result'Class; + R : in out Result'Class; Options : AUnit_Options := Default_Options) is pragma Unreferenced (Options); diff --git a/include/aunit/reporters/aunit-reporter-trx.ads b/include/aunit/reporters/aunit-reporter-trx.ads index 24a3a67..9322eff 100644 --- a/include/aunit/reporters/aunit-reporter-trx.ads +++ b/include/aunit/reporters/aunit-reporter-trx.ads @@ -36,7 +36,7 @@ package AUnit.Reporter.TRX is overriding procedure Report (Engine : TRX_Reporter; - R : Result'Class; + R : in out Result'Class; Options : AUnit_Options := Default_Options); end AUnit.Reporter.TRX; From b374c93c00c19c45e760d77e55f9747ada415441 Mon Sep 17 00:00:00 2001 From: Tama McGlinn Date: Tue, 9 Mar 2021 21:58:26 +0100 Subject: [PATCH 4/5] Properly ignore the long line url --- include/aunit/reporters/aunit-reporter-trx.adb | 2 ++ 1 file changed, 2 insertions(+) diff --git a/include/aunit/reporters/aunit-reporter-trx.adb b/include/aunit/reporters/aunit-reporter-trx.adb index 72b2382..2909a16 100644 --- a/include/aunit/reporters/aunit-reporter-trx.adb +++ b/include/aunit/reporters/aunit-reporter-trx.adb @@ -134,7 +134,9 @@ package body AUnit.Reporter.TRX is end Report_Test_Name; -- I found this example trx file + pragma Style_Checks ("M200"); -- Allow long lines -- https://github.com/x97mdr/pickles/blob/master/src/Pickles/Pickles.Test/results-example-mstest.trx + pragma Style_Checks ("M79"); -- it says UnitTestResult can have StdOut (text) and ErrorInfo -- containing Message and StackTrace procedure Report_Test (Test_Cursor : Test_Data_Vecs.Cursor) is From 701ce8aa4d59462ff7fc0a4881a0290cb97b7518 Mon Sep 17 00:00:00 2001 From: Tama McGlinn Date: Tue, 9 Mar 2021 22:21:10 +0100 Subject: [PATCH 5/5] Only allow the TRX reporter in the full_runtime I decided to just add a full_runtime directory; any other reporters that people want to add can be added to this directory --- .../{ => full_runtime}/aunit-reporter-trx.adb | 3 ++- .../{ => full_runtime}/aunit-reporter-trx.ads | 0 lib/gnat/aunit.gpr | 13 +++++++++++-- 3 files changed, 13 insertions(+), 3 deletions(-) rename include/aunit/reporters/{ => full_runtime}/aunit-reporter-trx.adb (99%) rename include/aunit/reporters/{ => full_runtime}/aunit-reporter-trx.ads (100%) diff --git a/include/aunit/reporters/aunit-reporter-trx.adb b/include/aunit/reporters/full_runtime/aunit-reporter-trx.adb similarity index 99% rename from include/aunit/reporters/aunit-reporter-trx.adb rename to include/aunit/reporters/full_runtime/aunit-reporter-trx.adb index 2909a16..94705f8 100644 --- a/include/aunit/reporters/aunit-reporter-trx.adb +++ b/include/aunit/reporters/full_runtime/aunit-reporter-trx.adb @@ -155,7 +155,8 @@ package body AUnit.Reporter.TRX is Put_Line (File, "Assertion failed on line" & SU.To_String (Test.Line) & " of " & SU.To_String (Test.Failure_Source_Name) - & ": """ & SU.To_String (Test.Failure_Message) & """"); + & ": """ + & SU.To_String (Test.Failure_Message) & """"); else Put_Line (File, "Raised " & SU.To_String (Test.Exception_Name) & ":"); diff --git a/include/aunit/reporters/aunit-reporter-trx.ads b/include/aunit/reporters/full_runtime/aunit-reporter-trx.ads similarity index 100% rename from include/aunit/reporters/aunit-reporter-trx.ads rename to include/aunit/reporters/full_runtime/aunit-reporter-trx.ads diff --git a/lib/gnat/aunit.gpr b/lib/gnat/aunit.gpr index d07f63d..cb0fb48 100644 --- a/lib/gnat/aunit.gpr +++ b/lib/gnat/aunit.gpr @@ -6,14 +6,23 @@ project AUnit is type Compilation_Mode_Type is ("Devel", "Install"); Mode : Compilation_Mode_Type := external ("AUNIT_BUILD_MODE", "Install"); + Reporters := ("../../include/aunit/reporters"); + + case AUnit_Shared.Runtime is + when "full" => + Reporters := Reporters & ("../../include/aunit/reporters/full_runtime"); + when others => + null; + end case; + for Source_Dirs use ("../../include/aunit/framework", "../../include/aunit/containers", - "../../include/aunit/reporters", "../../include/aunit/framework/" & AUnit_Shared.Except, "../../include/aunit/framework/" & AUnit_Shared.Calend, "../../include/aunit/framework/" & AUnit_Shared.Memory, - "../../include/aunit/framework/" & AUnit_Shared.FileIO); + "../../include/aunit/framework/" & AUnit_Shared.FileIO) + & Reporters; for Library_Dir use AUnit_Shared.Library_Dir;