Natools

Check-in [444efe557e]
Login
Overview
Comment:tests: new interface using finalization to ensure reporting is correct in all code paths
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 444efe557e47dc82852b83ada249fdb81426b622
User & Date: nat on 2014-01-24 21:59:20
Other Links: manifest | tags
Context
2014-01-25
16:04
s_expressions-test_tools: add versions of Dump_Atom and Test_Atom for the new Test type check-in: 9ff0437f97 user: nat tags: trunk
2014-01-24
21:59
tests: new interface using finalization to ensure reporting is correct in all code paths check-in: 444efe557e user: nat tags: trunk
2014-01-23
22:17
s_expressions-parsers-tests: new test for Subparser interface check-in: d02a180cc6 user: nat tags: trunk
Changes

Modified src/natools-tests.adb from [a382eaf70e] to [e65e6f7869].

12
13
14
15
16
17
18




19
20
21
22
23
24
25
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29







+
+
+
+







-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------


package body Natools.Tests is

   ------------------------
   -- Helper Subprograms --
   ------------------------

   function To_Result (Succeeded : Boolean) return Result is
   begin
      if Succeeded then
         return Success;
      else
         return Fail;
35
36
37
38
39
40
41

























































































42
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

   begin
      Item (Report, Test_Name, Code);
      Info (Report,
            "Exception " & Ada.Exceptions.Exception_Name (Ex) & " raised:");
      Info (Report, Ada.Exceptions.Exception_Message (Ex));
   end Report_Exception;



   -----------------
   -- Test Object --
   -----------------

   function Item
     (Report : access Reporter'Class;
      Name : String;
      Default_Outcome : Result := Success)
     return Test is
   begin
      return Test'(Ada.Finalization.Limited_Controlled with
         Report => Report,
         Name => Ada.Strings.Unbounded.To_Unbounded_String (Name),
         Info => Info_Lists.Empty_List,
         Outcome => Default_Outcome,
         Finalized => False);
   end Item;


   procedure Set_Result (Object : in out Test; Outcome : in Result) is
   begin
      Object.Outcome := Outcome;
   end Set_Result;


   procedure Info (Object : in out Test; Text : in String) is
   begin
      Object.Info.Append (Text);
   end Info;


   procedure Report_Exception
     (Object : in out Test;
      Ex     : in Ada.Exceptions.Exception_Occurrence;
      Code   : in Result := Error) is
   begin
      Set_Result (Object, Code);
      Info
        (Object,
         "Exception " & Ada.Exceptions.Exception_Name (Ex) & " raised:");
      Info (Object, Ada.Exceptions.Exception_Message (Ex));
   end Report_Exception;


   procedure Fail (Object : in out Test; Text : in String := "") is
   begin
      Set_Result (Object, Fail);
      if Text /= "" then
         Info (Object, Text);
      end if;
   end Fail;


   procedure Error (Object : in out Test; Text : in String := "") is
   begin
      Set_Result (Object, Error);
      if Text /= "" then
         Info (Object, Text);
      end if;
   end Error;


   procedure Skip (Object : in out Test; Text : in String := "") is
   begin
      Set_Result (Object, Skipped);
      if Text /= "" then
         Info (Object, Text);
      end if;
   end Skip;


   overriding procedure Finalize (Object : in out Test) is
      Cursor : Info_Lists.Cursor;
   begin
      if not Object.Finalized then
         Object.Finalized := True;
         Object.Report.Item
           (Ada.Strings.Unbounded.To_String (Object.Name),
            Object.Outcome);
         Cursor := Object.Info.First;
         while Info_Lists.Has_Element (Cursor) loop
            Object.Report.Info (Info_Lists.Element (Cursor));
            Info_Lists.Next (Cursor);
         end loop;
      end if;
   end Finalize;

end Natools.Tests;

Modified src/natools-tests.ads from [a9f7e4daed] to [052149f59b].

28
29
30
31
32
33
34




35
36
37
38
39
40
41
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45







+
+
+
+







--                                                                          --
-- Tests are gathered into sections, which can be nested. What a section    --
-- exactly means is left to the implementation of this interface.           --
------------------------------------------------------------------------------

with Ada.Exceptions;

private with Ada.Finalization;
private with Ada.Strings.Unbounded;
private with Ada.Containers.Indefinite_Doubly_Linked_Lists;

package Natools.Tests is
   pragma Preelaborate (Tests);

   type Reporter is interface;
   type Result is (Success, Fail, Error, Skipped);
   type Result_Summary is array (Result) of Natural;

78
79
80
81
82
83
84

















































85
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

     (Report    : in out Reporter'Class;
      Test_Name : String;
      Ex        : Ada.Exceptions.Exception_Occurrence;
      Code      : Result := Error);
      --  Append to Report a new Item, whose result is Code, along with
      --    a description of the exception Ex as Info entries.


   -----------------
   -- Test Object --
   -----------------

   type Test (<>) is tagged limited private;
      --  An object of type Test hold information about a single test.
      --  It contains a reference to a Reporter object, which is filled with
      --  held info when the Test object is finalized.

   function Item
     (Report : access Reporter'Class;
      Name : String;
      Default_Outcome : Result := Success)
     return Test;
      --  Create a new Test object with the given Name

   procedure Set_Result (Object : in out Test; Outcome : in Result);
      --  Set the test result

   procedure Info (Object : in out Test; Text : in String);
      --  Append the given text as extra information related to the test

   procedure Report_Exception
     (Object : in out Test;
      Ex     : in Ada.Exceptions.Exception_Occurrence;
      Code   : in Result := Error);
      --  Append information about Ex to the test and set its result state

   procedure Fail (Object : in out Test; Text : in String := "");
   procedure Error (Object : in out Test; Text : in String := "");
   procedure Skip (Object : in out Test; Text : in String := "");
      --  Set the result state and append Text info in a single call

private

   package Info_Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists
     (String);

   type Test (Report : access Reporter'Class) is
     new Ada.Finalization.Limited_Controlled with record
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Info : Info_Lists.List;
      Outcome : Result;
      Finalized : Boolean := False;
   end record;

   overriding procedure Finalize (Object : in out Test);

end Natools.Tests;