-----------------------------------------------------------------------
-- AUnit utils - Helper for writing unit tests
-- Copyright (C) 2009, 2010, 2011, 2012, 2013, 2017, 2019, 2021, 2022 Stephane Carrez
-- Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
-- http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
-----------------------------------------------------------------------
with GNAT.Command_Line;
with GNAT.Regpat;
with GNAT.Traceback.Symbolic;
with Ada.Command_Line;
with Ada.Directories;
with Ada.IO_Exceptions;
with Ada.Text_IO;
with Ada.Calendar.Formatting;
with Ada.Exceptions;
with Ada.Containers;
with Util.Strings;
with Util.Measures;
with Util.Files;
with Util.Strings.Vectors;
with Util.Log.Loggers;
package body Util.Tests is
Test_Properties : Util.Properties.Manager;
-- When a test uses external test files to match a result against a well
-- defined content, it can be difficult to maintain those external files.
-- The Assert_Equal_Files can automatically maintain the reference
-- file by updating it with the lastest test result.
--
-- Of course, using this mode means the test does not validate anything.
Update_Test_Files : Boolean := False;
-- The default timeout for a test case execution.
Default_Timeout : Duration := 60.0;
-- A prefix that is added to the test class names. Adding a prefix is useful when
-- the same testsuite is executed several times with different configurations. It allows
-- to track and identify the tests in different environments and have a global view
-- in Jenkins. See option '-p prefix'.
Harness_Prefix : Unbounded_String;
-- Verbose flag activated by the '-v' option.
Verbose_Flag : Boolean := False;
-- When not empty, defines the name of the test that is enabled. Other tests are disabled.
-- This is initialized by the -r test option.
Enabled_Test : Unbounded_String;
-- ------------------------------
-- Get a path to access a test file.
-- ------------------------------
function Get_Path (File : String) return String is
Dir : constant String := Get_Parameter ("test.dir", ".");
begin
return Dir & "/" & File;
end Get_Path;
-- ------------------------------
-- Get a path to create a test file.
-- ------------------------------
function Get_Test_Path (File : String) return String is
Dir : constant String := Get_Parameter ("test.result.dir", "regtests/results");
begin
return Dir & "/" & File;
end Get_Test_Path;
-- ------------------------------
-- Get the timeout for the test execution.
-- ------------------------------
function Get_Test_Timeout (Name : in String) return Duration is
Prop_Name : constant String := "test.timeout." & Name;
Value : constant String := Test_Properties.Get (Prop_Name,
Duration'Image (Default_Timeout));
begin
return Duration'Value (Value);
exception
when Constraint_Error =>
return Default_Timeout;
end Get_Test_Timeout;
-- ------------------------------
-- Get the testsuite harness prefix. This prefix is added to the test class name.
-- By default it is empty. It is allows to execute the test harness on different
-- environment (ex: MySQL or SQLlite) and be able to merge and collect the two result
-- sets together.
-- ------------------------------
function Get_Harness_Prefix return String is
begin
return To_String (Harness_Prefix);
end Get_Harness_Prefix;
-- ------------------------------
-- Get a test configuration parameter.
-- ------------------------------
function Get_Parameter (Name : String;
Default : String := "") return String is
begin
return Test_Properties.Get (Name, Default);
end Get_Parameter;
-- ------------------------------
-- Get the test configuration properties.
-- ------------------------------
function Get_Properties return Util.Properties.Manager is
begin
return Test_Properties;
end Get_Properties;
-- ------------------------------
-- Get a new unique string
-- ------------------------------
function Get_Uuid return String is
Time : constant Ada.Calendar.Time := Ada.Calendar.Clock;
Year : Ada.Calendar.Year_Number;
Month : Ada.Calendar.Month_Number;
Day : Ada.Calendar.Day_Number;
T : Ada.Calendar.Day_Duration;
V : Long_Long_Integer;
begin
Ada.Calendar.Split (Date => Time,
Year => Year,
Month => Month,
Day => Day,
Seconds => T);
V := (Long_Long_Integer (Year) * 365 * 24 * 3600 * 1000)
+ (Long_Long_Integer (Month) * 31 * 24 * 3600 * 1000)
+ (Long_Long_Integer (Day) * 24 * 3600 * 1000)
+ (Long_Long_Integer (T * 1000));
return "U" & Util.Strings.Image (V);
end Get_Uuid;
-- ------------------------------
-- Get the verbose flag that can be activated with the -v option.
-- ------------------------------
function Verbose return Boolean is
begin
return Verbose_Flag;
end Verbose;
-- ------------------------------
-- Returns True if the test with the given name is enabled.
-- By default all the tests are enabled. When the -r test option is passed
-- all the tests are disabled except the test specified by the -r option.
-- ------------------------------
function Is_Test_Enabled (Name : in String) return Boolean is
begin
return Length (Enabled_Test) = 0 or else Enabled_Test = Name;
end Is_Test_Enabled;
-- ------------------------------
-- Check that the value matches what we expect.
-- ------------------------------
procedure Assert_Equals (T : in Test'Class;
Expect, Value : in Ada.Calendar.Time;
Message : in String := "Test failed";
Source : String := GNAT.Source_Info.File;
Line : Natural := GNAT.Source_Info.Line) is
use Ada.Calendar.Formatting;
use Ada.Calendar;
begin
T.Assert (Condition => Image (Expect) = Image (Value),
Message => Message & ": expecting '" & Image (Expect) & "'"
& " value was '" & Image (Value) & "'",
Source => Source,
Line => Line);
end Assert_Equals;
-- ------------------------------
-- Check that the value matches what we expect.
-- ------------------------------
procedure Assert_Equals (T : in Test'Class;
Expect, Value : in String;
Message : in String := "Test failed";
Source : String := GNAT.Source_Info.File;
Line : Natural := GNAT.Source_Info.Line) is
begin
T.Assert (Condition => Expect = Value,
Message => Message & ": expecting '" & Expect & "'"
& " value was '" & Value & "'",
Source => Source,
Line => Line);
end Assert_Equals;
-- ------------------------------
-- Check that the value matches what we expect.
-- ------------------------------
procedure Assert_Equals (T : in Test'Class;
Expect : in String;
Value : in Unbounded_String;
Message : in String := "Test failed";
Source : String := GNAT.Source_Info.File;
Line : Natural := GNAT.Source_Info.Line) is
begin
Assert_Equals (T => T,
Expect => Expect,
Value => To_String (Value),
Message => Message,
Source => Source,
Line => Line);
end Assert_Equals;
-- ------------------------------
-- Check that the value matches the regular expression
-- ------------------------------
procedure Assert_Matches (T : in Test'Class;
Pattern : in String;
Value : in Unbounded_String;
Message : in String := "Test failed";
Source : String := GNAT.Source_Info.File;
Line : Natural := GNAT.Source_Info.Line) is
begin
Assert_Matches (T => T,
Pattern => Pattern,
Value => To_String (Value),
Message => Message,
Source => Source,
Line => Line);
end Assert_Matches;
-- ------------------------------
-- Check that the value matches the regular expression
-- ------------------------------
procedure Assert_Matches (T : in Test'Class;
Pattern : in String;
Value : in String;
Message : in String := "Test failed";
Source : String := GNAT.Source_Info.File;
Line : Natural := GNAT.Source_Info.Line) is
use GNAT.Regpat;
Regexp : constant Pattern_Matcher := Compile (Expression => Pattern,
Flags => Multiple_Lines);
begin
T.Assert (Condition => Match (Regexp, Value),
Message => Message & ". Value '" & Value & "': Does not Match '"
& Pattern & "'",
Source => Source,
Line => Line);
end Assert_Matches;
-- ------------------------------
-- Check that the file exists.
-- ------------------------------
procedure Assert_Exists (T : in Test'Class;
File : in String;
Message : in String := "Test failed";
Source : String := GNAT.Source_Info.File;
Line : Natural := GNAT.Source_Info.Line) is
begin
T.Assert (Condition => Ada.Directories.Exists (File),
Message => Message & ": file '" & File & "' does not exist",
Source => Source,
Line => Line);
end Assert_Exists;
-- ------------------------------
-- Check that two files are equal. This is intended to be used by
-- tests that create files that are then checked against patterns.
-- ------------------------------
procedure Assert_Equal_Files (T : in Test_Case'Class;
Expect : in String;
Test : in String;
Message : in String := "Test failed";
Source : String := GNAT.Source_Info.File;
Line : Natural := GNAT.Source_Info.Line) is
use Util.Files;
use type Ada.Containers.Count_Type;
use type Util.Strings.Vectors.Vector;
Expect_File : Util.Strings.Vectors.Vector;
Test_File : Util.Strings.Vectors.Vector;
Same : Boolean;
begin
begin
if not Ada.Directories.Exists (Expect) then
T.Assert (Condition => False,
Message => "Expect file '" & Expect & "' does not exist",
Source => Source, Line => Line);
end if;
Read_File (Path => Expect,
Into => Expect_File);
Read_File (Path => Test,
Into => Test_File);
exception
when others =>
if Update_Test_Files then
Ada.Directories.Copy_File (Source_Name => Test,
Target_Name => Expect);
else
raise;
end if;
end;
if Expect_File.Length /= Test_File.Length then
if Update_Test_Files then
Ada.Directories.Copy_File (Source_Name => Test,
Target_Name => Expect);
end if;
-- Check file sizes
Assert_Equals (T => T,
Expect => Natural (Expect_File.Length),
Value => Natural (Test_File.Length),
Message => Message & ": Invalid number of lines",
Source => Source,
Line => Line);
end if;
Same := Expect_File = Test_File;
if Same then
return;
end if;
if Update_Test_Files then
Ada.Directories.Copy_File (Source_Name => Test,
Target_Name => Expect);
end if;
T.Assert (Condition => False,
Message => Message & ": Content is different on some lines",
Source => Source,
Line => Line);
end Assert_Equal_Files;
-- ------------------------------
-- Check that two files are equal. This is intended to be used by
-- tests that create files that are then checked against patterns.
-- ------------------------------
procedure Assert_Equal_Files (T : in Test'Class;
Expect : in String;
Test : in String;
Message : in String := "Test failed";
Source : String := GNAT.Source_Info.File;
Line : Natural := GNAT.Source_Info.Line) is
use Util.Files;
use type Ada.Containers.Count_Type;
use type Util.Strings.Vectors.Vector;
Expect_File : Util.Strings.Vectors.Vector;
Test_File : Util.Strings.Vectors.Vector;
Same : Boolean;
begin
begin
if not Ada.Directories.Exists (Expect) then
T.Assert (Condition => False,
Message => "Expect file '" & Expect & "' does not exist",
Source => Source, Line => Line);
end if;
Read_File (Path => Expect,
Into => Expect_File);
Read_File (Path => Test,
Into => Test_File);
exception
when others =>
if Update_Test_Files then
Ada.Directories.Copy_File (Source_Name => Test,
Target_Name => Expect);
else
raise;
end if;
end;
if Expect_File.Length /= Test_File.Length then
if Update_Test_Files then
Ada.Directories.Copy_File (Source_Name => Test,
Target_Name => Expect);
end if;
-- Check file sizes
Assert_Equals (T => T,
Expect => Natural (Expect_File.Length),
Value => Natural (Test_File.Length),
Message => Message & ": Invalid number of lines",
Source => Source,
Line => Line);
end if;
Same := Expect_File = Test_File;
if Same then
return;
end if;
if Update_Test_Files then
Ada.Directories.Copy_File (Source_Name => Test,
Target_Name => Expect);
end if;
Fail (T => T,
Message => Message & ": Content is different on some lines",
Source => Source,
Line => Line);
end Assert_Equal_Files;
-- ------------------------------
-- Report a test failed.
-- ------------------------------
procedure Fail (T : in Test'Class;
Message : in String := "Test failed";
Source : in String := GNAT.Source_Info.File;
Line : in Natural := GNAT.Source_Info.Line) is
begin
T.Assert (False, Message, Source, Line);
end Fail;
-- ------------------------------
-- Default initialization procedure.
-- ------------------------------
procedure Initialize_Test (Props : in Util.Properties.Manager) is
begin
null;
end Initialize_Test;
-- ------------------------------
-- The main testsuite program. This launches the tests, collects the
-- results, create performance logs and set the program exit status
-- according to the testsuite execution status.
--
-- The Initialize procedure is called before launching the unit tests. It is intended
-- to configure the tests according to some external environment (paths, database access).
--
-- The Finish procedure is called after the test suite has executed.
-- ------------------------------
procedure Harness (Name : in String) is
use GNAT.Command_Line;
use Ada.Text_IO;
use type Util.XUnit.Status;
procedure Help;
procedure Help is
begin
Put_Line ("Test harness: " & Name);
Put ("Usage: harness [-l label] [-xml result.xml] [-t timeout] [-p prefix] [-v]"
& "[-config file.properties] [-d dir] [-r testname]");
Put_Line ("[-update]");
Put_Line ("-l label Print the label in the test summary result");
Put_Line ("-xml file Produce an XML test report");
Put_Line ("-config file Specify a test configuration file");
Put_Line ("-d dir Change the current directory to ");
Put_Line ("-t timeout Test execution timeout in seconds");
Put_Line ("-v Activate the verbose test flag");
Put_Line ("-p prefix Add the prefix to the test class names");
Put_Line ("-r testname Run only the tests for the given testsuite name");
Put_Line ("-update Update the test reference files if a file");
Put_Line (" is missing or the test generates another output");
Put_Line (" (See Assert_Equals_File)");
Ada.Command_Line.Set_Exit_Status (2);
end Help;
Perf : aliased Util.Measures.Measure_Set;
Result : Util.XUnit.Status;
XML : Boolean := False;
Output : Ada.Strings.Unbounded.Unbounded_String;
Chdir : Ada.Strings.Unbounded.Unbounded_String;
Label : String (1 .. 16) := (others => ' ');
begin
loop
case Getopt ("h u v l: x: t: p: c: config: d: r: update help xml: timeout:") is
when ASCII.NUL =>
exit;
when 'c' =>
declare
Name : constant String := Parameter;
begin
Test_Properties.Load_Properties (Name);
Default_Timeout := Get_Test_Timeout ("default");
exception
when Ada.IO_Exceptions.Name_Error =>
Ada.Text_IO.Put_Line ("Cannot find configuration file: " & Name);
Ada.Command_Line.Set_Exit_Status (2);
return;
end;
when 'd' =>
Chdir := To_Unbounded_String (Parameter);
when 'l' =>
if Parameter'Length > Label'Length then
Label := Parameter (Parameter'First .. Parameter'First + Label'Length - 1);
else
Label := (others => ' ');
Label (Label'First .. Label'First + Parameter'Length - 1) := Parameter;
end if;
when 'u' =>
Update_Test_Files := True;
when 't' =>
begin
Default_Timeout := Duration'Value (Parameter);
exception
when Constraint_Error =>
Ada.Text_IO.Put_Line ("Invalid timeout: " & Parameter);
Ada.Command_Line.Set_Exit_Status (2);
return;
end;
when 'r' =>
Enabled_Test := To_Unbounded_String (Parameter);
when 'p' =>
Harness_Prefix := To_Unbounded_String (Parameter & " ");
when 'v' =>
Verbose_Flag := True;
when 'x' =>
XML := True;
Output := To_Unbounded_String (Parameter);
when others =>
Help;
return;
end case;
end loop;
-- Initialization is optional. Get the log configuration by reading the property
-- file 'samples/log4j.properties'. The 'log.util' logger will use a DEBUG level
-- and write the message in 'result.log'.
Util.Log.Loggers.Initialize (Test_Properties);
Initialize (Test_Properties);
if Length (Chdir) /= 0 then
begin
Ada.Directories.Set_Directory (To_String (Chdir));
exception
when Ada.IO_Exceptions.Name_Error =>
Put_Line ("Invalid directory " & To_String (Chdir));
Ada.Command_Line.Set_Exit_Status (1);
return;
end;
end if;
declare
procedure Runner is new Util.XUnit.Harness (Suite);
S : Util.Measures.Stamp;
begin
Util.Measures.Set_Current (Perf'Unchecked_Access);
Runner (To_String (Output), XML,
(if (for all C of Label => C = ' ') then "" else Label), Result);
Util.Measures.Report (Perf, S, "Testsuite execution");
Util.Measures.Write (Perf, "Test measures", Name);
end;
Finish (Result);
-- Program exit status reflects the testsuite result
if Result /= Util.XUnit.Success then
Ada.Command_Line.Set_Exit_Status (1);
else
Ada.Command_Line.Set_Exit_Status (0);
end if;
exception
when Invalid_Switch =>
Put_Line ("Invalid Switch " & Full_Switch);
Help;
return;
when Invalid_Parameter =>
Put_Line ("No parameter for " & Full_Switch);
Help;
return;
when E : others =>
Put_Line ("Exception: " & Ada.Exceptions.Exception_Name (E));
Put_Line ("Message: " & Ada.Exceptions.Exception_Message (E));
Put_Line ("Stacktrace:");
Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E));
Ada.Command_Line.Set_Exit_Status (4);
end Harness;
end Util.Tests;