ada-libraries
/
gnatbdd
mirror of https://github.com/briot/gnatbdd
1
0
Fork 0
Code Issues Releases Wiki Activity

Add support for comparing tables 

Review the code in bdd-asserts_generic so that exceptions can be extended
to include advanced information like table or multiline diffs.
This commit is contained in:
Emmanuel Briot 2014-06-04 15:11:28 +02:00
parent c2d5d27f84
commit 3b9f0c149a
19 changed files with 781 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -7,7 +7,9 @@ build:
# Adding new scenarios does not erquire recompiling the driver
test: build_driver
./obj/driver --output=full
./obj/driver --output=hide_passed
#./obj/driver --output=hide_passed
#./obj/driver --output=quiet
#./obj/driver --output=dots
# Driver only needs to be recompiled when the step definitions change
build_driver: features/step_definitions/*

12
features/first.feature
View File

@ -21,3 +21,15 @@ Feature: A first feature
| 10 | 20 | + | 30 |
| 20 | 10 | - | 10 |
| 10 | 20 | + | 40 |
Scenario: Checking stack contents
When I enter "10"
And I enter "20"
And I enter "30"
And I enter "40"
Then the stack should contain
| value |
| 10 |
| 20 |
| 31 |
| 40 |

9
features/step_definitions/calculator.adb
View File

@ -43,4 +43,13 @@ package body Calculator is
return Stack (Stack_Top - 1);
end Peek;
function Peek_Stack return Integer_Array is
Result : Integer_Array (Stack'First .. Stack_Top - 1);
begin
for R in Result'Range loop
Result (R) := Stack (R);
end loop;
return Result;
end Peek_Stack;
end Calculator;

3
features/step_definitions/calculator.ads
View File

@ -1,7 +1,10 @@
package Calculator is
type Integer_Array is array (Natural range <>) of Integer;
procedure Reset;
procedure Enter (Value : String);
function Peek return Integer;
function Peek_Stack return Integer_Array;
end Calculator;

14
features/step_definitions/mysteps1.adb
View File

@ -1,4 +1,5 @@
with BDD.Asserts; use BDD.Asserts;
with BDD.Tables; use BDD.Tables;
with Calculator; use Calculator;
package body MySteps1 is
@ -15,7 +16,18 @@ package body MySteps1 is
procedure Then_I_Should_Read (Result : Integer) is
begin
Assert (Result, Peek, "checking top of the stack");
Assert (Result, Peek);
end Then_I_Should_Read;
procedure Then_The_Stack_Should_Contain (Expected : BDD.Tables.Table) is
Actual : Table := Create;
Stack : constant Integer_Array := Peek_Stack;
begin
for S in Stack'Range loop
Actual.Put (Column => 1, Row => S, Value => Stack (S)'Img);
end loop;
Assert (Expected => Expected, Actual => Actual);
end Then_The_Stack_Should_Contain;
end MySteps1;

5
features/step_definitions/mysteps1.ads
View File

@ -1,3 +1,5 @@
with BDD.Tables;
package MySteps1 is
-- @given ^an empty calculator$
@ -10,4 +12,7 @@ package MySteps1 is
-- @then ^I should read (\d+)$
procedure Then_I_Should_Read (Result : Integer);
-- @then the stack should contain
procedure Then_The_Stack_Should_Contain (Expected : BDD.Tables.Table);
end MySteps1;

266
src/bdd-asserts.adb Normal file
View File

@ -0,0 +1,266 @@
-----------------------------------------------------------------------------
-- G N A T C O L L --
-- --
-- Copyright (C) 2014, AdaCore --
-- --
-- This library is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 3, or (at your option) any later --
-- version. This library is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY 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 --
-- <http://www.gnu.org/licenses/>. --
-- --
------------------------------------------------------------------------------
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO; use Ada.Text_IO;
with GNATCOLL.Terminal; use GNATCOLL.Terminal;
with GNATCOLL.Traces; use GNATCOLL.Traces;
package body BDD.Asserts is
Me : constant Trace_Handle := Create ("BDD.ASSERTS");
type Error_With_Table is new Error_Details with record
Val1, Val2 : BDD.Tables.Table;
end record;
type Error_With_Table_Access is access all Error_With_Table'Class;
overriding procedure Display
(Self : not null access Error_With_Table;
Term : not null access GNATCOLL.Terminal.Terminal_Info'Class;
File : Ada.Text_IO.File_Type;
Prefix : String := "");
procedure Diff
(Expected, Actual : BDD.Tables.Table;
On_Error : access procedure (Msg : String);
On_Cell : access function
(Row : Integer;
Column_In_Expected : Integer;
Expected, Actual : String;
Status : Scenario_Status)
return Boolean);
-- Do a diff between the two tables, and calls On_Cell for each cell in
-- the expected table.
-- When On_Cell returns False, stops iterating.
-- On_Error is called when the diff could not be completed
----------
-- Diff --
----------
procedure Diff
(Expected, Actual : BDD.Tables.Table;
On_Error : access procedure (Msg : String);
On_Cell : access function
(Row : Integer;
Column_In_Expected : Integer;
Expected, Actual : String;
Status : Scenario_Status)
return Boolean)
is
Columns : array (1 .. Expected.Height) of Integer;
-- What column of Actual matches the column of Expected.
begin
-- Do we have column names ?
if Actual.Get_Column_Name (1) /= "" then
for C in Columns'Range loop
Columns (C) :=
Actual.Column_Number (Expected.Get_Column_Name (C));
if Columns (C) = 0 then
On_Error
("Column not found in actual result: '"
& Expected.Get_Column_Name (C) & "'");
return;
end if;
end loop;
else
for C in Columns'Range loop
Columns (C) := C;
end loop;
end if;
For_All_Rows :
for Row in 1 .. Expected.Height loop
for Column in 1 .. Expected.Width loop
declare
E : constant String := Trim
(Expected.Get (Column => Column, Row => Row),
Ada.Strings.Both);
A : constant String := Trim
(Actual.Get (Column => Columns (Column), Row => Row),
Ada.Strings.Both);
Status : constant Scenario_Status :=
(if E /= A then Status_Failed else Status_Passed);
begin
exit For_All_Rows when not On_Cell
(Row => Row,
Column_In_Expected => Column,
Expected => E,
Actual => A,
Status => Status);
end;
end loop;
end loop For_All_Rows;
end Diff;
------------
-- Assert --
------------
procedure Assert
(Expected, Actual : BDD.Tables.Table;
Msg : String := "";
Location : String := GNAT.Source_Info.Source_Location;
Entity : String := GNAT.Source_Info.Enclosing_Entity)
is
procedure On_Error (Msg : String);
procedure On_Error (Msg : String) is
E : constant Error_Details_Access := new Error_Details;
begin
E.Set_Details
(Details => Msg,
Msg => "",
Location => Location,
Entity => Entity);
E.Raise_Exception;
end On_Error;
function On_Cell
(Row : Integer;
Column_In_Expected : Integer;
E, A : String;
Status : Scenario_Status) return Boolean;
function On_Cell
(Row : Integer;
Column_In_Expected : Integer;
E, A : String;
Status : Scenario_Status) return Boolean
is
Error : Error_With_Table_Access;
begin
if Status = Status_Failed then
Trace (Me, "Diff row=" & Row'Img
& " column=" & Column_In_Expected'Img
& " '" & E & "' != '" & A & "'");
Error := new Error_With_Table;
Error.Set_Details
(Details => "",
Msg => Msg,
Location => Location,
Entity => Entity);
Error.Val1 := Expected;
Error.Val2 := Actual;
Error.Raise_Exception;
return False;
end if;
return True;
end On_Cell;
begin
Diff (Expected, Actual, On_Error'Access, On_Cell'Access);
end Assert;
-------------
-- Display --
-------------
overriding procedure Display
(Self : not null access Error_With_Table;
Term : not null access GNATCOLL.Terminal.Terminal_Info'Class;
File : Ada.Text_IO.File_Type;
Prefix : String := "")
is
Current_Row : Integer := -1;
Widths : array (1 .. Self.Val1.Width) of Natural := (others => 0);
procedure On_Error (Msg : String) is null;
function Compute_Width
(Row : Integer;
Column_In_Expected : Integer;
E, A : String;
Status : Scenario_Status) return Boolean;
function Compute_Width
(Row : Integer;
Column_In_Expected : Integer;
E, A : String;
Status : Scenario_Status) return Boolean
is
W : Integer;
begin
if Status = Status_Failed then
W := A'Length + E'Length + 4;
else
W := A'Length;
end if;
Widths (Column_In_Expected) := Integer'Max
(Widths (Column_In_Expected), W);
return True;
end Compute_Width;
function On_Cell
(Row : Integer;
Column_In_Expected : Integer;
E, A : String;
Status : Scenario_Status) return Boolean;
function On_Cell
(Row : Integer;
Column_In_Expected : Integer;
E, A : String;
Status : Scenario_Status) return Boolean
is
W : Integer := 0;
begin
if Row /= 1 and then Row /= Current_Row then
Put_Line (File, "|");
end if;
if Row /= Current_Row then
Current_Row := Row;
Put (File, Prefix);
end if;
Term.Set_Color
(Term => Ada.Text_IO.Standard_Output,
Style => Reset_All);
Put (File, "| ");
Term.Set_Color
(Term => File,
Foreground => BDD.Step_Colors (Status));
Put (File, A);
W := W + A'Length;
if Status = Status_Failed then
Term.Set_Color
(Term => File,
Foreground => BDD.Config_Color);
Put (File, " /= " & E);
W := W + 4 + E'Length;
end if;
Put (File, (1 .. Widths (Column_In_Expected) - W + 1 => ' '));
return True;
end On_Cell;
begin
Diff (Self.Val1, Self.Val2, On_Error'Access, Compute_Width'Access);
Diff (Self.Val1, Self.Val2, On_Error'Access, On_Cell'Access);
Put_Line (File, "|");
end Display;
end BDD.Asserts;

23
src/bdd-asserts.ads
View File

@ -27,13 +27,14 @@
-- to make the exception message useful.
with BDD.Asserts_Generic; use BDD.Asserts_Generic;
with BDD.Tables; use BDD.Tables;
with GNAT.Source_Info;
package BDD.Asserts is
package BAG renames BDD.Asserts_Generic;
package Integer_Equals
is new BAG.Asserts (Integer, Integer'Image, "=", "=");
is new BAG.Asserts (Integer, Integer'Image, "=", "/=");
procedure Assert
(Val1, Val2 : Integer;
Msg : String := "";
@ -42,7 +43,7 @@ package BDD.Asserts is
renames Integer_Equals.Assert;
package Integer_Less_Than
is new BAG.Asserts (Integer, Integer'Image, "<", "<");
is new BAG.Asserts (Integer, Integer'Image, "<", ">=");
procedure Assert_Less_Than
(Val1, Val2 : Integer;
Msg : String := "";
@ -52,7 +53,7 @@ package BDD.Asserts is
function Identity (Str : String) return String is (Str);
package String_Equals
is new BAG.Asserts (String, Identity, "=", "=");
is new BAG.Asserts (String, Identity, "=", "/=");
procedure Assert
(Val1, Val2 : String;
Msg : String := "";
@ -60,4 +61,20 @@ package BDD.Asserts is
Entity : String := GNAT.Source_Info.Enclosing_Entity)
renames String_Equals.Assert;
procedure Assert
(Expected, Actual : BDD.Tables.Table;
Msg : String := "";
Location : String := GNAT.Source_Info.Source_Location;
Entity : String := GNAT.Source_Info.Enclosing_Entity);
-- Compare two tables.
-- Although it would be possible to do the comparison yourself, cell by
-- cell, it is better to use this procedure. It will provide a nicer
-- formatting of the output.
-- The Actual table must have at least as many columns as Expected,
-- although it could contain more (which allows you to share code to create
-- the table). When there are more columns, the comparison is done as
-- follows:
-- * Either column names are provided, and they are used.
-- * or the Expected.Height first column are compared with Expected.
end BDD.Asserts;

170
src/bdd-asserts_generic.adb
View File

@ -21,60 +21,125 @@
-- --
------------------------------------------------------------------------------
with Ada.Assertions; use Ada.Assertions;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with GNATCOLL.Utils; use GNATCOLL.Utils;
with BDD.Formatters; use BDD.Formatters;
package body BDD.Asserts_Generic is
package String_Maps is new Ada.Containers.Indefinite_Hashed_Maps
(String, String, Ada.Strings.Hash, "=", "=");
Current_Exception : Assert_Error := No_Error;
-- The details associated with the current exception.
-- There is only one exception being processed at a time (in a task-free
-- environment), so we need only store a single instance, to avoid
-- wasting memory. Since we do not know when an exception_occurrence is
-- no longer used, we would not know when to free the memory otherwise).
Messages : String_Maps.Map;
Id : Positive := 1; -- a unique id for all raised exceptions
---------
-- Get --
---------
---------------------------
-- Raise_Assertion_Error --
---------------------------
procedure Raise_Assertion_Error
(Msg : String;
Details : String;
Location : String;
Entity : String)
is
Full : constant String :=
(if Msg /= "" then Msg & ASCII.LF else "")
& Details & ASCII.LF & "at " & Entity & " " & Location;
M : constant String :=
'@' & Image (Id, Min_Width => 0) & '@' & Msg & Details;
Actual : String renames
M (M'First .. M'First + Integer'Min (M'Length - 1, 200));
function Get (E : Exception_Occurrence) return Assert_Error is
begin
-- Preserve as much as possible of the message (in case this exception
-- is handled by code other than GNATBdd), but insert a unique id at
-- the beginning so that we can retrieve the full message from the map.
Id := Id + 1;
Messages.Include (Actual, Full);
raise Unexpected_Result with Actual;
end Raise_Assertion_Error;
-----------------
-- Get_Message --
-----------------
function Get_Message (E : Exception_Occurrence) return String is
Actual : constant String := Exception_Message (E);
C : constant String_Maps.Cursor := Messages.Find (Actual);
begin
if not String_Maps.Has_Element (C) then
return Actual;
if Exception_Identity (E) = Unexpected_Result'Identity then
return Current_Exception;
else
return String_Maps.Element (C);
return No_Error;
end if;
end Get_Message;
end Get;
-------------
-- Details --
-------------
function Details (Self : Assert_Error) return Error_Details_Access is
begin
return Error_Details_Access (Self.Get);
end Details;
-----------------
-- Set_Details --
-----------------
procedure Set_Details
(Self : not null access Error_Details;
Details : String := "";
Msg : String := "";
Location : String := GNAT.Source_Info.Source_Location;
Entity : String := GNAT.Source_Info.Enclosing_Entity)
is
begin
Self.Details := To_Unbounded_String (Details);
Self.Msg := To_Unbounded_String (Msg);
Self.Location := To_Unbounded_String ("at " & Entity & "::" & Location);
end Set_Details;
---------------------
-- Raise_Exception --
---------------------
procedure Raise_Exception (Self : not null access Error_Details) is
begin
Current_Exception.Set (Self);
raise Unexpected_Result with
To_String (Self.Msg) & ' ' & To_String (Self.Details)
& To_String (Self.Location);
end Raise_Exception;
-------------
-- Display --
-------------
procedure Display
(Self : Assert_Error;
Term : not null access GNATCOLL.Terminal.Terminal_Info'Class;
File : Ada.Text_IO.File_Type;
Prefix : String := "")
is
begin
Display (Self.Details, Term, File, Prefix);
end Display;
-------------
-- Display --
-------------
procedure Display
(Self : not null access Error_Details;
Term : not null access GNATCOLL.Terminal.Terminal_Info'Class;
File : Ada.Text_IO.File_Type;
Prefix : String := "")
is
pragma Unreferenced (Term);
begin
if Self.Msg /= "" then
Indent (File, To_String (Self.Msg), Prefix => Prefix);
if Element (Self.Msg, Length (Self.Msg)) /= ASCII.LF then
New_Line (File);
end if;
end if;
if Self.Details /= "" then
Indent (File, To_String (Self.Details), Prefix => Prefix);
if Element (Self.Details, Length (Self.Details)) /= ASCII.LF then
New_Line (File);
end if;
end if;
Indent (File, To_String (Self.Location), Prefix => Prefix);
New_Line (File);
end Display;
--------------------
-- From_Exception --
--------------------
function From_Exception (E : Exception_Occurrence) return Assert_Error is
Error : constant Error_Details_Access := new Error_Details;
Result : Assert_Error;
begin
Error.Set_Details (Details => Exception_Information (E));
Result.Set (Error);
return Result;
end From_Exception;
-------------
-- Asserts --
@ -92,12 +157,17 @@ package body BDD.Asserts_Generic is
Location : String := GNAT.Source_Info.Source_Location;
Entity : String := GNAT.Source_Info.Enclosing_Entity)
is
Error : Error_Details_Access;
begin
if not Operator (Val1, Val2) then
Raise_Assertion_Error
(Msg,
Image (Val1) & ' ' & Operator_Image & ' ' & Image (Val2),
Location, Entity);
Error := new Error_Details;
Error.Set_Details
(Msg => Msg,
Details =>
Image (Val1) & ' ' & Not_Operator_Image & ' ' & Image (Val2),
Location => Location,
Entity => Entity);
Error.Raise_Exception;
end if;
end Assert;
end Asserts;

115
src/bdd-asserts_generic.ads
View File

@ -23,32 +23,110 @@
-- An assertion library for use with GNATBDD
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Source_Info;
with GNATCOLL.Refcount; use GNATCOLL.Refcount;
with GNATCOLL.Terminal; use GNATCOLL.Terminal;
package BDD.Asserts_Generic is
-------------------
-- Assert_Error --
-------------------
-- Steps might fail in several ways. For instance, they might raise an
-- unexpected exception, or perform explicit tests.
-- When such a test fails, it should raise an exception. We encourage you
-- to raise an exception via the following API, which allows you to embed
-- details about the failure, as well as provide a nice way to display them
-- to the user.
-- The reason to use the API below is that Ada exception messages are
-- limited in length, and thus cannot embed the rich information necessary
-- to understand the error without launching a debugger.
Unexpected_Result : exception;
procedure Raise_Assertion_Error
(Msg : String;
Details : String;
Location : String;
Entity : String);
-- Raises an assertion error, storing the full message in a temporary
-- location since exception messages are limited in length and would not
-- show the whole message
type Assert_Error is tagged private;
No_Error : constant Assert_Error;
-- A reference counted-type that describes the details for an error.
-- This type is tagged only so that the dot notation can be used for calls.
-- If you need to store the details of an exception, this is the type that
-- should be stored, not the underlying Error_Details_Access, which might
-- be freed at any point if no Assert_Error still exists.
function Get_Message (E : Exception_Occurrence) return String;
-- Retrieve the whole message from the exception (which should have been
function Get (E : Exception_Occurrence) return Assert_Error;
-- Retrieve the details from the exception (which should have been
-- raises by Raise_Assert_Error above, or one of the Assert procedures
-- below).
type Error_Details is tagged private;
type Error_Details_Access is access all Error_Details'Class;
-- the details stored in an assert_Error.
-- You are encouraged to extend this type if you need to provide additional
-- details about errors.
procedure Free (Self : in out Error_Details) is null;
-- Free the memory used by Self.
-- This should not be called directly.
function Details (Self : Assert_Error) return Error_Details_Access;
-- Returns the actual details of the exception.
-- Do not store the result access, which might be freed when Self is no
-- longer referenced by your application.
procedure Set_Details
(Self : not null access Error_Details;
Details : String := "";
Msg : String := "";
Location : String := GNAT.Source_Info.Source_Location;
Entity : String := GNAT.Source_Info.Enclosing_Entity);
-- Store basic information in Self.
--
-- Msg is in general a static string provided by the user, to help pinpoint
-- which particular assert failed. It will often be left to the empty
-- string, since there is already quite a lot of context when the error is
-- displayed to the user.
--
-- Details should be used to describe the expected and actual values.
--
-- Location and Entity are used to point to the code location where the
-- error is raised.
procedure Raise_Exception (Self : not null access Error_Details);
pragma No_Return (Raise_Exception);
-- Wraps Self in an Assert_Error, and raise the Unexpected_Result
-- exception.
-- When this exception is handled, one can use Get to retrieve the
-- Assert_Error, and then Details to get access to Self again.
procedure Display
(Self : Assert_Error;
Term : not null access GNATCOLL.Terminal.Terminal_Info'Class;
File : Ada.Text_IO.File_Type;
Prefix : String := "");
procedure Display
(Self : not null access Error_Details;
Term : not null access GNATCOLL.Terminal.Terminal_Info'Class;
File : Ada.Text_IO.File_Type;
Prefix : String := "");
-- Display the details on File, using Term to set appropriate colors.
function From_Exception (E : Exception_Occurrence) return Assert_Error;
-- Create from the information contained in the exception
--------------
-- Generics --
--------------
-- The following API provides convenient ways to perform tests and raise
-- appropriate exceptions. A number of predefined instances are provided
-- in the BDD.Asserts package.
generic
type T (<>) is limited private;
with function Image (V : T) return String;
with function Operator (V1, V2 : T) return Boolean;
Operator_Image : String;
Not_Operator_Image : String;
package Asserts is
@ -66,4 +144,17 @@ package BDD.Asserts_Generic is
end Asserts;
private
type Error_Details is new Refcounted with record
Details : Unbounded_String;
Msg : Unbounded_String;
Location : Unbounded_String;
end record;
package Errors is new GNATCOLL.Refcount.Smart_Pointers (Error_Details);
type Assert_Error is new Errors.Ref with null record;
No_Error : constant Assert_Error := (Errors.Null_Ref with null record);
end BDD.Asserts_Generic;

97
src/bdd-codegen.adb
View File

@ -26,9 +26,11 @@ with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Regpat; use GNAT.Regpat;
with GNATCOLL.Traces; use GNATCOLL.Traces;
with GNATCOLL.Utils; use GNATCOLL.Utils;
package body BDD.Codegen is
Me : constant Trace_Handle := Create ("BDD.CODEGEN");
Cst_Procedure : constant String := "procedure ";
Cst_Procedure_Re : constant Pattern_Matcher := Compile
@ -40,7 +42,7 @@ package body BDD.Codegen is
& "\))?(\s+with .*?)?;", -- end of group 2
Case_Insensitive or Single_Line);
Cst_Package_Re : constant Pattern_Matcher :=
Compile ("^package ([_\.\w]+)", Case_Insensitive);
Compile ("^package ([_\.\w]+)", Case_Insensitive or Multiple_Lines);
Cst_Comment_Re : constant Pattern_Matcher :=
Compile ("--\s*@(given|then|when)\s+");
@ -210,9 +212,15 @@ package body BDD.Codegen is
Subprogram : GNAT.Strings.String_Access;
Colon : Integer;
List : Param_List_Access;
List_Last : Integer := 0;
Expected_Params : Natural;
Table_Param : GNAT.Strings.String_Access;
-- Name of the parameter for a Table (null if no table expected)
begin
Trace (Me, "Found regexp " & Regexp);
-- Check this is a valid regular expression
begin
@ -266,35 +274,62 @@ package body BDD.Codegen is
begin
List := new Param_List (Params'Range);
for P in Params'Range loop
Colon := Find_Char (Params (P).all, ':');
if Colon > Params (P)'Last then
Put_Line
(Standard_Error,
"Error while parsing subprogram declaration for step '"
& Regexp & "'");
return;
end if;
declare
D : String renames Params (P).all;
Name : constant String := Trim (D (D'First .. Colon - 1));
Typ : constant String := Trim (D (Colon + 1 .. D'Last));
begin
Colon := Find_Char (D, ':');
if Colon > D'Last then
Put_Line
(Standard_Error,
"Error while parsing subprogram declaration for step '"
& Regexp & "'");
return;
if P > Expected_Params then
-- Is this a Table parameter ?
if Typ = "BDD.Tables.Table" then
if Table_Param /= null then
Put_Line
(Standard_Error,
"Multiple table parameters is unsupported for"
& " step '" & Regexp & "'");
Free (List);
Free (Subprogram);
return;
end if;
Table_Param := new String'(Name);
else
Put_Line
(Standard_Error,
"Mismatch between the number of parenthesis in the"
& " regexp and the subprogram parameters for step '"
& Regexp & "'");
Free (List);
Free (Subprogram);
return;
end if;
else
List (P) :=
(Name => new String'(Name),
Of_Type => new String'(Typ));
List_Last := P;
end if;
List (P) :=
(Name => new String'(Trim (D (D'First .. Colon - 1))),
Of_Type => new String'(Trim (D (Colon + 1 .. D'Last))));
end;
end loop;
Free (Params);
end;
else
List := new Param_List (1 .. 0);
end if;
if List'Length /= Expected_Params then
if List_Last /= Expected_Params then
Put_Line
(Standard_Error,
"Mismatch between the number of parenthesis in the regexp and the"
& " subprogram parameters for step '" & Regexp & "'");
"Mismatch between the number of parenthesis in the"
& " regexp and the subprogram parameters for step '"
& Regexp & "'");
Free (List);
Free (Subprogram);
return;
@ -306,7 +341,7 @@ package body BDD.Codegen is
Data.Steps_Count := Data.Steps_Count + 1;
Data.Max_Parameter_Count := Integer'Max
(Data.Max_Parameter_Count, List'Length);
(Data.Max_Parameter_Count, List_Last);
if Data.Steps_Count /= 1 then
Append (Data.Matchers, " els");
@ -320,14 +355,16 @@ package body BDD.Codegen is
& " if Execute then" & ASCII.LF
& " " & Subprogram.all);
if List'Length = 0 then
if List_Last = 0
and then Table_Param = null
then
Append (Data.Matchers, ";");
else
for L in List'Range loop
Append (Data.Matchers, " (");
for L in List'First .. List_Last loop
if L /= List'First then
Append (Data.Matchers, ",");
else
Append (Data.Matchers, "(");
end if;
Append (Data.Matchers,
ASCII.LF & " "
@ -341,6 +378,17 @@ package body BDD.Codegen is
& Image (1 + L - List'First, Min_Width => 0)
& ").Last)"));
end loop;
if Table_Param /= null then
if List_Last > 0 then
Append (Data.Matchers, ",");
end if;
Append (Data.Matchers,
ASCII.LF & " "
& Table_Param.all
& " => Step.Table");
end if;
Append (Data.Matchers, ");");
end if;
@ -355,6 +403,7 @@ package body BDD.Codegen is
& " : constant Pattern_Matcher := Compile" & ASCII.LF
& " (""" & Escape (Regexp) & """);" & ASCII.LF);
Free (Table_Param);
Free (Subprogram);
Free (List);
end Parse_Subprogram_Def;
@ -378,6 +427,10 @@ package body BDD.Codegen is
Found : Boolean := False;
begin
if Contents /= null then
if Active (Me) then
Trace (Me, "Check steps in " & File.Display_Full_Name);
end if;
Pos := Contents'First;
-- Find the start of the package

25
src/bdd-features.adb
View File

@ -21,10 +21,8 @@
-- --
------------------------------------------------------------------------------
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Strings.Fixed; use Ada.Strings, Ada.Strings.Fixed;
with Ada.Unchecked_Deallocation;
with BDD.Asserts_Generic; use BDD.Asserts_Generic;
with GNATCOLL.Traces; use GNATCOLL.Traces;
with GNATCOLL.Utils; use GNATCOLL.Utils;
@ -355,7 +353,7 @@ package body BDD.Features is
Trace (Me, "Free step at line" & Self.Line'Img);
Self.Text := Null_Unbounded_String;
Self.Multiline := Null_Unbounded_String;
Self.Error_Msg := Null_Unbounded_String;
Self.Error := No_Error;
Self.Status := Status_Passed;
Self.Table := No_Table;
Unchecked_Free (Self.Match);
@ -396,21 +394,22 @@ package body BDD.Features is
procedure Set_Status
(Self : not null access Step_Record;
Status : BDD.Scenario_Status;
Error_Msg : String := "")
Details : Assert_Error := No_Error)
is
begin
Self.Status := Status;
Self.Error_Msg := To_Unbounded_String (Error_Msg);
Self.Error := Details;
end Set_Status;
---------------
-- Error_Msg --
---------------
-------------------
-- Error_Details --
-------------------
function Error_Msg (Self : not null access Step_Record) return String is
function Error_Details
(Self : not null access Step_Record) return Assert_Error is
begin
return To_String (Self.Error_Msg);
end Error_Msg;
return Self.Error;
end Error_Details;
------------
-- Status --
@ -561,10 +560,10 @@ package body BDD.Features is
exception
when E : Unexpected_Result =>
Step.Set_Status (Status_Failed, Get_Message (E));
Step.Set_Status (Status_Failed, Get (E));
exit;
when E : others =>
Step.Set_Status (Status_Failed, Exception_Information (E));
Step.Set_Status (Status_Failed, From_Exception (E));
exit;
end;
end loop;

11
src/bdd-features.ads
View File

@ -25,6 +25,7 @@
with Ada.Containers.Doubly_Linked_Lists;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with BDD.Asserts_Generic; use BDD.Asserts_Generic;
with BDD.Tables; use BDD.Tables;
with GNATCOLL.Refcount; use GNATCOLL.Refcount;
with GNAT.Regpat; use GNAT.Regpat;
@ -56,17 +57,19 @@ package BDD.Features is
function Line (Self : not null access Step_Record) return Positive;
function Text (Self : not null access Step_Record) return String;
function Multiline (Self : not null access Step_Record) return String;
function Table (Self : not null access Step_Record) return BDD.Tables.Table;
function Multiline (Self : not null access Step_Record) return String;
-- Return the components of the step
procedure Set_Status
(Self : not null access Step_Record;
Status : BDD.Scenario_Status;
Error_Msg : String := "");
Details : BDD.Asserts_Generic.Assert_Error := No_Error);
function Status
(Self : not null access Step_Record) return BDD.Scenario_Status;
function Error_Msg (Self : not null access Step_Record) return String;
function Error_Details
(Self : not null access Step_Record)
return BDD.Asserts_Generic.Assert_Error;
-- Set the status for a specific step
procedure Set_Match_Info
@ -210,7 +213,7 @@ private
Line : Positive;
Text : Ada.Strings.Unbounded.Unbounded_String;
Multiline : Ada.Strings.Unbounded.Unbounded_String;
Error_Msg : Ada.Strings.Unbounded.Unbounded_String;
Error : Assert_Error;
Status : BDD.Scenario_Status;
Table : BDD.Tables.Table;
Match : Match_Array_Access;

97
src/bdd-formatters.adb
View File

@ -21,11 +21,12 @@
-- --
------------------------------------------------------------------------------
with Ada.Containers; use Ada.Containers;
with Ada.Text_IO; use Ada.Text_IO;
with BDD.Tables; use BDD.Tables;
with GNATCOLL.Utils; use GNATCOLL.Utils;
with GNAT.Regpat; use GNAT.Regpat;
with Ada.Containers; use Ada.Containers;
with Ada.Text_IO; use Ada.Text_IO;
with BDD.Asserts_Generic; use BDD.Asserts_Generic;
with BDD.Tables; use BDD.Tables;
with GNATCOLL.Utils; use GNATCOLL.Utils;
with GNAT.Regpat; use GNAT.Regpat;
package body BDD.Formatters is
@ -269,6 +270,30 @@ package body BDD.Formatters is
Display_Location (Self, Scenario);
end Display_Scenario_Header;
------------
-- Indent --
------------
procedure Indent
(File : Ada.Text_IO.File_Type;
Text : String;
Prefix : String := "")
is
Start, Last : Integer;
begin
Start := Text'First;
while Start <= Text'Last loop
Last := Line_End (Text, Start);
if Last < Start then -- empty line
New_Line (File);
Start := Last + 2;
else
Put (File, Prefix & Text (Start .. Last));
Start := Last + 1;
end if;
end loop;
end Indent;
------------------
-- Display_Step --
------------------
@ -278,25 +303,6 @@ package body BDD.Formatters is
Scenario : BDD.Features.Scenario;
Step : not null access BDD.Features.Step_Record'Class)
is
procedure Indent (Text : String);
-- Display text on multiple lines, and indent each line as needed
procedure Indent (Text : String) is
Start, Last : Integer;
begin
Start := Text'First;
while Start <= Text'Last loop
Last := Line_End (Text, Start);
if Last < Start then -- empty line
New_Line;
Start := Last + 2;
else
Put (" " & Text (Start .. Last));
Start := Last + 1;
end if;
end loop;
end Indent;
Info : constant Match_Array := Step.Match_Info;
begin
if Self.Term.Has_Colors then
@ -372,27 +378,28 @@ package body BDD.Formatters is
(Term => Ada.Text_IO.Standard_Output,
Foreground => BDD.Step_Colors (Step.Status));
Put_Line (" """"""");
Indent (Multi);
Indent (Ada.Text_IO.Standard_Output, Multi, Prefix => " ");
Put_Line (" """"""");
end if;
end;
if Step.Table /= No_Table then
declare
Error : constant Assert_Error := Step.Error_Details;
begin
Self.Term.Set_Color
(Term => Ada.Text_IO.Standard_Output,
Foreground => BDD.Step_Colors (Step.Status));
Step.Table.Display
(Ada.Text_IO.Standard_Output, Prefix => " ");
end if;
declare
Msg : constant String := Step.Error_Msg;
begin
if Msg /= "" then
Self.Term.Set_Color
(Term => Ada.Text_IO.Standard_Output,
Foreground => BDD.Step_Colors (Step.Status));
Indent (Msg);
if Error /= No_Error then
Display (Error, Self.Term, Ada.Text_IO.Standard_Output,
Prefix => " ");
else
-- Display the default step's table, since it full matched or was
-- not even run.
if Step.Table /= No_Table then
Step.Table.Display
(Ada.Text_IO.Standard_Output, Prefix => " ");
end if;
end if;
end;
@ -515,6 +522,22 @@ package body BDD.Formatters is
New_Line;
end Scenario_Completed;
---------------------------
-- Nested_Scenario_Start --
---------------------------
overriding procedure Nested_Scenario_Start
(Self : in out Formatter_Full;
Scenario : BDD.Features.Scenario;
Is_First : Boolean)
is
pragma Unreferenced (Self, Scenario);
begin
if not Is_First then
New_Line;
end if;
end Nested_Scenario_Start;
--------------------
-- Step_Completed --
--------------------

26
src/bdd-formatters.ads
View File

@ -23,6 +23,7 @@
-- The formatters are used to display output for the user
with Ada.Text_IO;
private with Ada.Containers.Doubly_Linked_Lists;
with BDD.Features; use BDD.Features;
with GNATCOLL.Terminal; use GNATCOLL.Terminal;
@ -49,6 +50,17 @@ package BDD.Formatters is
-- Called when a scenario has completed.
-- Its status has already been set
procedure Nested_Scenario_Start
(Self : in out Formatter;
Scenario : BDD.Features.Scenario;
Is_First : Boolean) is null;
procedure Nested_Scenario_Completed
(Self : in out Formatter;
Scenario : BDD.Features.Scenario) is null;
-- Called when a nested scenario starts or has completed.
-- These are the scenarios generated from an Outline Scenario examples.
-- Its status has already been set
procedure Step_Completed
(Self : in out Formatter;
Scenario : BDD.Features.Scenario;
@ -88,6 +100,10 @@ package BDD.Formatters is
(Self : in out Formatter_Full;
Scenario : BDD.Features.Scenario;
Step : not null access BDD.Features.Step_Record'Class);
overriding procedure Nested_Scenario_Start
(Self : in out Formatter_Full;
Scenario : BDD.Features.Scenario;
Is_First : Boolean);
----------
-- Dots --
@ -131,6 +147,16 @@ package BDD.Formatters is
(Self : in out Formatter_Hide_Passed;
Scenario : BDD.Features.Scenario);
-----------
-- Utils --
-----------
procedure Indent
(File : Ada.Text_IO.File_Type;
Text : String;
Prefix : String := "");
-- Print a multi-line text so that each line is indented by Prefix
private
package Scenario_Lists is new Ada.Containers.Doubly_Linked_Lists
(BDD.Features.Scenario);

5
src/bdd-runner.adb
View File

@ -124,6 +124,7 @@ package body BDD.Runner is
Scenario : BDD.Features.Scenario)
is
Show_Steps : Boolean;
Is_First : Boolean := True;
procedure Run_Step
(Scenario : BDD.Features.Scenario;
@ -198,7 +199,11 @@ package body BDD.Runner is
Self.Scenario_Stats (Nested.Status) + 1;
else
Self.Format.Nested_Scenario_Start
(Nested, Is_First => Is_First);
Is_First := False;
Nested.Foreach_Step (Run_Step'Access);
Self.Format.Nested_Scenario_Completed (Nested);
end if;
if Is_Nested then

38
src/bdd-tables.adb
View File

@ -85,8 +85,28 @@ package body BDD.Tables is
else
R.Names.Replace_Element (Column, Name);
end if;
R.Width := Integer'Max (R.Width, Column);
end Set_Column_Name;
---------------------
-- Get_Column_Name --
---------------------
function Get_Column_Name
(Self : Table;
Column : Positive) return String
is
R : constant not null access Table_Record := Self.Get;
begin
if R.Names.Is_Empty
or else Integer (R.Names.Length) < Column
then
return "";
else
return R.Names.Element (Column);
end if;
end Get_Column_Name;
---------
-- Put --
---------
@ -103,18 +123,20 @@ package body BDD.Tables is
R.Insert (Column, Value);
end Do_Update;
SR : constant not null access Table_Record := Self.Get;
begin
if Row > Integer (Self.Get.Rows.Length) then
if Row > Integer (SR.Rows.Length) then
declare
R : String_Vectors.Vector;
begin
R.Reserve_Capacity
(Ada.Containers.Count_Type (Integer'Max (Column, Self.Width)));
Self.Get.Rows.Append (R);
SR.Rows.Append (R);
end;
end if;
Self.Get.Rows.Update_Element (Row, Do_Update'Unrestricted_Access);
SR.Rows.Update_Element (Row, Do_Update'Unrestricted_Access);
SR.Width := Integer'Max (SR.Width, Column);
end Put;
---------
@ -128,7 +150,13 @@ package body BDD.Tables is
return String
is
begin
return Self.Get.Rows.Element (Row).Element (Column);
if Column > Self.Width
or else Row > Self.Height
then
return "";
else
return Self.Get.Rows.Element (Row).Element (Column);
end if;
end Get;
---------
@ -150,7 +178,7 @@ package body BDD.Tables is
function Width (Self : Table) return Natural is
begin
return Natural (Self.Get.Names.Length);
return Self.Get.Width;
end Width;
------------

5
src/bdd-tables.ads
View File

@ -28,6 +28,7 @@ with Ada.Containers.Indefinite_Vectors;
with Ada.Containers.Vectors;
with Ada.Text_IO; use Ada.Text_IO;
with GNATCOLL.Refcount; use GNATCOLL.Refcount;
with GNATCOLL.Terminal; use GNATCOLL.Terminal;
package BDD.Tables is
@ -53,6 +54,9 @@ package BDD.Tables is
(Self : Table;
Column : Positive;
Name : String);
function Get_Column_Name
(Self : Table;
Column : Positive) return String;
-- Set the name of the Column-th column
procedure Put
@ -95,6 +99,7 @@ private
type Table_Record is new GNATCOLL.Refcount.Refcounted with record
Names : String_Vectors.Vector;
Width : Natural := 0;
Rows : Row_Vectors.Vector; -- does not include column titles
end record;

6
src/gnatbdd.adb
View File

@ -3,12 +3,14 @@
-- step definitions provided by the user, as well as the predefined
-- steps, regular expressions and mockups.
with BDD.Codegen; use BDD.Codegen;
with GNATCOLL.VFS; use GNATCOLL.VFS;
with BDD.Codegen; use BDD.Codegen;
with GNATCOLL.Traces; use GNATCOLL.Traces;
with GNATCOLL.VFS; use GNATCOLL.VFS;
procedure Gnatbdd is
Finder : Steps_Finder;
begin
GNATCOLL.Traces.Parse_Config_File;
Discover_Steps
(Finder,
Extension => ".ads",