diff --git a/include/aunit/reporters/aunit-reporter-combine.adb b/include/aunit/reporters/aunit-reporter-combine.adb new file mode 100644 index 0000000..d33675d --- /dev/null +++ b/include/aunit/reporters/aunit-reporter-combine.adb @@ -0,0 +1,23 @@ + +package body AUnit.Reporter.Combine is + + procedure Report + (Engine : Combined_Reporter; + R : in out Result'Class; + Options : AUnit_Options := Default_Options) is + + procedure Run_Reporter(Position : Reporter_Vecs.Cursor) is + Element : constant Reporter_Access := Reporter_Vecs.Element (Position); + begin + AUnit.Reporter.Report (Element.all, R, Options); + end Run_Reporter; + begin + Reporter_Vecs.Iterate (Engine.Reporters, Run_Reporter'Access); + end Report; + + procedure Add_Reporter (C : in out Combined_Reporter; R : access constant Reporter'Class) is + begin + C.Reporters.Append(R); + end Add_Reporter; + +end AUnit.Reporter.Combine; diff --git a/include/aunit/reporters/aunit-reporter-combine.ads b/include/aunit/reporters/aunit-reporter-combine.ads new file mode 100644 index 0000000..675c517 --- /dev/null +++ b/include/aunit/reporters/aunit-reporter-combine.ads @@ -0,0 +1,26 @@ +with Ada.Containers.Vectors; + +package AUnit.Reporter.Combine is + + type Combined_Reporter is new Reporter with private; + + overriding + procedure Report + (Engine : Combined_Reporter; + R : in out Result'Class; + Options : AUnit_Options := Default_Options); + + procedure Add_Reporter (C : in out Combined_Reporter; R : access constant Reporter'Class); + +private + + type Reporter_Access is access constant Reporter'Class; + + package Reporter_Vecs is new Ada.Containers.Vectors + (Element_Type => Reporter_Access, + Index_Type => Positive); + + type Combined_Reporter is new Reporter with record + Reporters : Reporter_Vecs.Vector; + end record; +end AUnit.Reporter.Combine; diff --git a/include/aunit/reporters/aunit-reporter-trx.adb b/include/aunit/reporters/aunit-reporter-trx.adb new file mode 100644 index 0000000..ac24fb3 --- /dev/null +++ b/include/aunit/reporters/aunit-reporter-trx.adb @@ -0,0 +1,290 @@ +with Ada.Calendar; +with Ada.Text_IO; +with Ada.Strings.Unbounded; +with Ada.Containers.Vectors; +with Ada_Containers; + +package body AUnit.Reporter.TRX is + + function Get_Reporter (Limited_Reporter : Reporter_Generator) return Reporter'Class is + pragma Unreferenced (Limited_Reporter); + begin + return T : TRX_Reporter; + end Get_Reporter; + + TRX_File : Ada.Text_IO.File_Type; + + procedure Open_XML_File is + use Ada.Text_IO; + begin + Create (TRX_File, Out_File, "testresult.trx"); + end; + + procedure Close_XML_File is + begin + Ada.Text_IO.Close (TRX_File); + end; + + procedure Initialize(Object: in out Reporter_Generator) is + pragma Unreferenced (Object); + begin + Open_XML_File; + end Initialize; + + procedure Finalize(Object: in out Reporter_Generator) is + pragma Unreferenced (Object); + begin + Close_XML_File; + end Finalize; + + procedure Put_Line (V : String) is + begin + Ada.Text_IO.Put_Line (TRX_File, V); + end; + + 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 : in out 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_Test (Test_Cursor : Test_Data_Vecs.Cursor); + procedure Report_Test_Name (Test_Cursor : Test_Data_Vecs.Cursor); + + procedure Report (Engine : TRX_Reporter; + R : in out Result'Class; + Options : AUnit_Options := Default_Options) + is + pragma Unreferenced (Engine); + pragma Unreferenced (Options); + + 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; + begin + Put_Line (""); + Put_Line (""); + Put_Line (" "); + Put_Line (" "); + Put_Line (" "); + + declare + Tests : constant Test_Data_Vecs.Vector := Get_All_Results (R); + begin + Put_Line (" "); + Iterate (Tests, Report_Test_Name'Access); + Put_Line (" "); + + Put_Line (" "); + Iterate (Tests, Report_Test'Access); + Put_Line (" "); + end; + + Put_Line (""); + 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; + + procedure Report_Test_Name (Test_Cursor : Test_Data_Vecs.Cursor) is + Test : constant Test_Data := Test_Data_Vecs.Element (Test_Cursor); + begin + Put_Line (" "); + 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 (" "); + if Test.Outcome /= Passed then + Put_Line (" "); + Put_Line (" "); + Put_Line (" "); + if Test.Outcome = Failed then + Put_Line ("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 ("Raised " & SU.To_String (Test.Exception_Name) & ":"); + Put_Line ("Exception message:"); + Put_Line (SU.To_String (Test.Exception_Message)); + end if; + Put_Line (" "); + if Test.Outcome = Error then + Put_Line (" "); + Put_Line (SU.To_String (Test.Backtrace)); + Put_Line (" "); + end if; + Put_Line (" "); + Put_Line (" "); + end if; + Put_Line (" "); + end Report_Test; + +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..7621de6 --- /dev/null +++ b/include/aunit/reporters/aunit-reporter-trx.ads @@ -0,0 +1,25 @@ +with Ada.Finalization; + +package AUnit.Reporter.TRX is + + type Reporter_Generator is new Ada.Finalization.Controlled with null record; + + function Get_Reporter (Limited_Reporter : Reporter_Generator) return Reporter'Class; + +private + + type TRX_Reporter is new AUnit.Reporter.Reporter with null record; + + overriding + procedure Report + (Engine : TRX_Reporter; + R : in out Result'Class; + Options : AUnit_Options := Default_Options); + + overriding + procedure Initialize(Object: in out Reporter_Generator); + + overriding + procedure Finalize(Object: in out Reporter_Generator); + +end AUnit.Reporter.TRX;