From bf8e7781e9f6b4aab48e8f0401920f1b8ad681c5 Mon Sep 17 00:00:00 2001
From: Jed Barber <jjbarber@y7mail.com>
Date: Sat, 19 Dec 2020 18:55:21 +1100
Subject: Abort timer for long running tests added, but won't deal with
 infinite loops yet

---
 src/unit_tests.adb | 29 +++++++++++++++++++++--------
 src/unit_tests.ads | 12 ++++++++----
 2 files changed, 29 insertions(+), 12 deletions(-)

diff --git a/src/unit_tests.adb b/src/unit_tests.adb
index 3c31ef9..55866af 100644
--- a/src/unit_tests.adb
+++ b/src/unit_tests.adb
@@ -17,7 +17,8 @@ package body Unit_Tests is
 
     function Run_Test
            (To_Run  : in Test;
-            Verbose : in Verbosity := Weak)
+            Verbose : in Verbosity := Weak;
+            Timeout : in Duration := 0.0)
         return Test_Result
     is
         Result : Test_Result;
@@ -26,7 +27,16 @@ package body Unit_Tests is
             Put ("Testing " & (-To_Run.Name) & "...");
         end if;
         begin
-            Result := To_Run.Func.all;
+            if Timeout > 0.0 then
+                select
+                    delay Timeout;
+                    Result := Fail;
+                then abort
+                    Result := To_Run.Func.all;
+                end select;
+            else
+                Result := To_Run.Func.all;
+            end if;
         exception
             when others => Result := Fail;
         end;
@@ -47,11 +57,12 @@ package body Unit_Tests is
 
     procedure Run_Test
            (To_Run  : in Test;
-            Verbose : in Verbosity := Weak)
+            Verbose : in Verbosity := Weak;
+            Timeout : in Duration := 0.0)
     is
         Result : Test_Result;
     begin
-        Result := Run_Test (To_Run, Verbose);
+        Result := Run_Test (To_Run, Verbose, Timeout);
     end Run_Test;
 
 
@@ -59,7 +70,8 @@ package body Unit_Tests is
 
     function Run_Tests
            (To_Run  : in Test_Array;
-            Verbose : in Verbosity := Weak)
+            Verbose : in Verbosity := Weak;
+            Timeout : in Duration := 0.0)
         return Test_Result_Array
     is
         Total_Count : Natural := To_Run'Length;
@@ -67,7 +79,7 @@ package body Unit_Tests is
         Results     : Test_Result_Array (To_Run'Range);
     begin
         for R in To_Run'Range loop
-            Results (R) := Run_Test (To_Run (R), Verbose);
+            Results (R) := Run_Test (To_Run (R), Verbose, Timeout);
             if Results (R) = Pass then
                 Pass_Count := Pass_Count + 1;
             end if;
@@ -84,13 +96,14 @@ package body Unit_Tests is
 
     procedure Run_Tests
            (To_Run  : in Test_Array;
-            Verbose : in Verbosity := Weak)
+            Verbose : in Verbosity := Weak;
+            Timeout : in Duration := 0.0)
     is
         Total_Count : Natural := To_Run'Length;
         Pass_Count  : Natural := 0;
     begin
         for T of To_Run loop
-            if Run_Test (T, Verbose) = Pass then
+            if Run_Test (T, Verbose, Timeout) = Pass then
                 Pass_Count := Pass_Count + 1;
             end if;
         end loop;
diff --git a/src/unit_tests.ads b/src/unit_tests.ads
index 90eccee..adb10f9 100644
--- a/src/unit_tests.ads
+++ b/src/unit_tests.ads
@@ -34,21 +34,25 @@ package Unit_Tests is
 
     function Run_Test
            (To_Run  : in Test;
-            Verbose : in Verbosity := Weak)
+            Verbose : in Verbosity := Weak;
+            Timeout : in Duration := 0.0)
         return Test_Result;
 
     procedure Run_Test
            (To_Run  : in Test;
-            Verbose : in Verbosity := Weak);
+            Verbose : in Verbosity := Weak;
+            Timeout : in Duration := 0.0);
 
     function Run_Tests
            (To_Run  : in Test_Array;
-            Verbose : in Verbosity := Weak)
+            Verbose : in Verbosity := Weak;
+            Timeout : in Duration := 0.0)
         return Test_Result_Array;
 
     procedure Run_Tests
            (To_Run  : in Test_Array;
-            Verbose : in Verbosity := Weak);
+            Verbose : in Verbosity := Weak;
+            Timeout : in Duration := 0.0);
 
 
 
-- 
cgit