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

Also make Feature an access type, for consistency. 

This also ensures that the parser does not have to care about unique
ids for features, this is taken care of automatically, making the task
of writting new parsers easier.
This commit is contained in:
Emmanuel Briot 2014-02-07 11:40:10 +01:00
parent f6757fc64b
commit 6ed248afa3
8 changed files with 129 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
src/bdd-features.adb
View File

@ -26,11 +26,56 @@ with Ada.Unchecked_Deallocation;
package body BDD.Features is
protected type Ids is
procedure Get_Next (Id : out Integer);
-- Get the next unique id
private
Current : Integer := 0;
end Ids;
---------
-- Ids --
---------
protected body Ids is
--------------
-- Get_Next --
--------------
procedure Get_Next (Id : out Integer) is
begin
Current := Current + 1;
Id := Current;
end Get_Next;
end Ids;
Feature_Ids : Ids;
------------
-- Create --
------------
function Create
(File : GNATCOLL.VFS.Virtual_File;
Name : String)
return not null access Feature_Record
is
Self : constant Feature := new Feature_Record;
begin
Self.Name := new String'(Trim (Name, Both));
Self.File := File;
Feature_Ids.Get_Next (Self.Id);
return Self;
end Create;
----------
-- Free --
----------
procedure Free (Self : in out Feature) is
procedure Free (Self : in out Feature_Record) is
begin
Self.File := No_File;
Self.Id := -1;
@ -38,21 +83,25 @@ package body BDD.Features is
Self.Description := Null_Unbounded_String;
end Free;
--------------
-- Set_Name --
--------------
----------
-- Free --
----------
procedure Set_Name (Self : in out Feature; Name : String) is
procedure Free (Self : in out Feature) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Feature_Record'Class, Feature);
begin
Free (Self.Name);
Self.Name := new String'(Trim (Name, Both));
end Set_Name;
if Self /= null then
Free (Self.all);
Unchecked_Free (Self);
end if;
end Free;
----------
-- Name --
----------
function Name (Self : Feature) return String is
function Name (Self : not null access Feature_Record) return String is
begin
if Self.Name = null then
return "";
@ -60,39 +109,22 @@ package body BDD.Features is
return Self.Name.all;
end Name;
--------------
-- Set_File --
--------------
procedure Set_File
(Self : in out Feature; File : GNATCOLL.VFS.Virtual_File) is
begin
Self.File := File;
end Set_File;
----------
-- File --
----------
function File (Self : Feature) return GNATCOLL.VFS.Virtual_File is
function File
(Self : not null access Feature_Record)
return GNATCOLL.VFS.Virtual_File is
begin
return Self.File;
end File;
-------------------
-- Set_Unique_Id --
-------------------
procedure Set_Unique_Id (Self : in out Feature; Id : Integer) is
begin
Self.Id := Id;
end Set_Unique_Id;
--------
-- Id --
--------
function Id (Self : Feature) return Integer is
function Id (Self : not null access Feature_Record) return Integer is
begin
return Self.Id;
end Id;
@ -194,20 +226,22 @@ package body BDD.Features is
-- Description --
-----------------
function Description (Self : Feature) return String is
function Description
(Self : not null access Feature_Record) return String is
begin
return To_String (Self.Description);
end Description;
---------------------
-- Add_Description --
---------------------
------------------------
-- Add_To_Description --
------------------------
procedure Add_Description (Self : in out Feature; Descr : String) is
procedure Add_To_Description
(Self : not null access Feature_Record; Descr : String) is
begin
-- Indent the description as it will be displayed
Append (Self.Description, " " & Descr & ASCII.LF);
end Add_Description;
end Add_To_Description;
--------------
-- Set_Text --

31
src/bdd-features.ads
View File

@ -82,29 +82,38 @@ package BDD.Features is
-- Feature --
-------------
type Feature is tagged limited private;
type Feature_Record (<>) is tagged limited private;
type Feature is access all Feature_Record'Class;
-- An object that represents a single feature and all its scenarios.
-- A specific features file might contain several features, but this object
-- only represents one of them.
--
-- This type has a discriminant to force the allocation through Create,
-- which ensures the feature has a unique id.
function Create
(File : GNATCOLL.VFS.Virtual_File;
Name : String)
return not null access Feature_Record;
-- Create and initialize a new feature
procedure Free (Self : in out Feature);
procedure Free (Self : in out Feature_Record);
-- Free the memory associated with Self
procedure Set_Unique_Id (Self : in out Feature; Id : Integer);
function Id (Self : Feature) return Integer;
function Id (Self : not null access Feature_Record) return Integer;
-- Set a unique id for the feature
procedure Set_Name (Self : in out Feature; Name : String);
function Name (Self : Feature) return String;
function Name (Self : not null access Feature_Record) return String;
-- The name of the feature
procedure Set_File
(Self : in out Feature; File : GNATCOLL.VFS.Virtual_File);
function File (Self : Feature) return GNATCOLL.VFS.Virtual_File;
function File
(Self : not null access Feature_Record) return GNATCOLL.VFS.Virtual_File;
-- The file in which the feature is defined
function Description (Self : Feature) return String;
procedure Add_Description (Self : in out Feature; Descr : String);
function Description (Self : not null access Feature_Record) return String;
procedure Add_To_Description
(Self : not null access Feature_Record; Descr : String);
-- Add some description information. Add_Description will be called once
-- for each line in the description.
@ -127,7 +136,7 @@ private
-- Make sure this type can be put in a list and automatically reclaim
-- storage when the list is clearer.
type Feature is tagged limited record
type Feature_Record is tagged limited record
File : GNATCOLL.VFS.Virtual_File;
Name : GNAT.Strings.String_Access;
Id : Integer;

30
src/bdd-formatters.adb
View File

@ -27,26 +27,26 @@ with GNATCOLL.Utils; use GNATCOLL.Utils;
package body BDD.Formatters is
function Scenario_Name
(Feature : BDD.Features.Feature'Class;
(Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class)
return String;
-- Return a string used to identify the scenario for the user.
procedure Display_Location
(Self : Formatter'Class;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class);
-- Display location information for the scenario
procedure Display_Scenario_Header
(Self : in out Formatter'Class;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class);
-- Display the feature and scenario headers, as needed.
procedure Display_Progress
(Self : in out Formatter'Class;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class);
-- Display the name of the scenario being run, if supported by the
-- terminal
@ -71,7 +71,7 @@ package body BDD.Formatters is
-------------------
function Scenario_Name
(Feature : BDD.Features.Feature'Class;
(Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class)
return String
is
@ -87,7 +87,7 @@ package body BDD.Formatters is
procedure Display_Location
(Self : Formatter'Class;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class)
is
begin
@ -107,7 +107,7 @@ package body BDD.Formatters is
procedure Display_Progress
(Self : in out Formatter'Class;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class)
is
Width : constant Integer := Self.Term.Get_Width;
@ -154,7 +154,7 @@ package body BDD.Formatters is
procedure Display_Scenario_Header
(Self : in out Formatter'Class;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class)
is
begin
@ -174,7 +174,7 @@ package body BDD.Formatters is
overriding procedure Scenario_Start
(Self : in out Formatter_Full;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class)
is
begin
@ -189,7 +189,7 @@ package body BDD.Formatters is
overriding procedure Scenario_Completed
(Self : in out Formatter_Full;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class;
Status : BDD.Scenario_Status)
is
@ -205,7 +205,7 @@ package body BDD.Formatters is
overriding procedure Scenario_Completed
(Self : in out Formatter_Dots;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class;
Status : BDD.Scenario_Status)
is
@ -229,7 +229,7 @@ package body BDD.Formatters is
overriding procedure Scenario_Start
(Self : in out Formatter_Quiet;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class)
is
begin
@ -242,7 +242,7 @@ package body BDD.Formatters is
overriding procedure Scenario_Completed
(Self : in out Formatter_Quiet;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class;
Status : BDD.Scenario_Status)
is
@ -257,7 +257,7 @@ package body BDD.Formatters is
procedure Scenario_Start
(Self : in out Formatter_Hide_Passed;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class)
is
begin
@ -270,7 +270,7 @@ package body BDD.Formatters is
overriding procedure Scenario_Completed
(Self : in out Formatter_Hide_Passed;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class;
Status : BDD.Scenario_Status)
is

18
src/bdd-formatters.ads
View File

@ -38,14 +38,14 @@ package BDD.Formatters is
procedure Scenario_Start
(Self : in out Formatter;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class) is null;
-- Display information about a feature and ascenario just before the
-- scenario is run.
procedure Scenario_Completed
(Self : in out Formatter;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class;
Status : BDD.Scenario_Status) is null;
-- Called when a scenario has completed
@ -63,11 +63,11 @@ package BDD.Formatters is
overriding procedure Scenario_Start
(Self : in out Formatter_Full;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class);
overriding procedure Scenario_Completed
(Self : in out Formatter_Full;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class;
Status : BDD.Scenario_Status);
@ -79,7 +79,7 @@ package BDD.Formatters is
overriding procedure Scenario_Completed
(Self : in out Formatter_Dots;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class;
Status : BDD.Scenario_Status);
@ -91,11 +91,11 @@ package BDD.Formatters is
overriding procedure Scenario_Start
(Self : in out Formatter_Quiet;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class);
overriding procedure Scenario_Completed
(Self : in out Formatter_Quiet;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class;
Status : BDD.Scenario_Status);
@ -107,11 +107,11 @@ package BDD.Formatters is
overriding procedure Scenario_Start
(Self : in out Formatter_Hide_Passed;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class);
overriding procedure Scenario_Completed
(Self : in out Formatter_Hide_Passed;
Feature : BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class;
Status : BDD.Scenario_Status);

11
src/bdd-parser.adb
View File

@ -36,6 +36,7 @@ package body BDD.Parser is
File : GNATCOLL.VFS.Virtual_File;
Runner : in out Abstract_Feature_Runner'Class)
is
pragma Unreferenced (Self);
type State_Type is (None, In_Feature,
In_Scenario,
In_String,
@ -184,10 +185,10 @@ package body BDD.Parser is
elsif Starts_With (Buffer (First_Char .. Line_E), Cst_Features) then
Finish_Feature;
F.Set_Unique_Id (Self.F_Id);
Self.F_Id := Self.F_Id + 1;
F.Set_File (File);
F.Set_Name (Buffer (First_Char + Cst_Features'Length .. Line_E));
F := Create
(File => File,
Name => Buffer (First_Char + Cst_Features'Length .. Line_E));
Runner.Feature_Start (F);
Index_In_Feature := 0;
State := In_Feature;
@ -296,7 +297,7 @@ package body BDD.Parser is
& Image (Line, 1);
elsif State = In_Feature then
F.Add_Description (Buffer (First_Char .. Line_E));
F.Add_To_Description (Buffer (First_Char .. Line_E));
elsif State = In_Scenario
or else State = In_Outline

14
src/bdd-parser.ads
View File

@ -36,14 +36,14 @@ package BDD.Parser is
procedure Feature_Start
(Self : in out Abstract_Feature_Runner;
Feature : in out BDD.Features.Feature'Class) is null;
Feature : not null access BDD.Features.Feature_Record'Class) is null;
-- Called on the first line of a feature.
-- At this stage, only the name and file or the feature are known, but none
-- of its scenarios
procedure Scenario_Start
(Self : in out Abstract_Feature_Runner;
Feature : in out BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class) is null;
-- Called on the first line of a scenario.
-- At this stage, only the name and location of the scenario are known, but
@ -51,13 +51,13 @@ package BDD.Parser is
procedure Scenario_End
(Self : in out Abstract_Feature_Runner;
Feature : in out BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class) is null;
-- Called when the last step in a scenario has been seen.
procedure Feature_End
(Self : in out Abstract_Feature_Runner;
Feature : in out BDD.Features.Feature'Class) is null;
Feature : not null access BDD.Features.Feature_Record'Class) is null;
-- Called when the last line of a feature has been seen.
type Feature_Parser is tagged private;
@ -73,10 +73,6 @@ package BDD.Parser is
-- Raises Syntax_Error when the file does not contain valid syntax.
private
type Feature_Parser is tagged record
F_Id : Natural := 1;
-- Unique Id for the features that are parsed.
-- This is increased for all new feature found by this parser.
end record;
type Feature_Parser is tagged null record;
end BDD.Parser;

4
src/bdd-runner.adb
View File

@ -103,7 +103,7 @@ package body BDD.Runner is
overriding procedure Scenario_Start
(Self : in out Feature_Runner;
Feature : in out BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class)
is
begin
@ -118,7 +118,7 @@ package body BDD.Runner is
overriding procedure Scenario_End
(Self : in out Feature_Runner;
Feature : in out BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class)
is
Status : Scenario_Status;

4
src/bdd-runner.ads
View File

@ -65,11 +65,11 @@ package BDD.Runner is
overriding procedure Scenario_Start
(Self : in out Feature_Runner;
Feature : in out BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class);
overriding procedure Scenario_End
(Self : in out Feature_Runner;
Feature : in out BDD.Features.Feature'Class;
Feature : not null access BDD.Features.Feature_Record'Class;
Scenario : not null access BDD.Features.Scenario_Record'Class);
private