1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
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
136
137
138
139
140
141
142
143
144
145
146
147
148
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A U N I T . T E S T _ C A S E S . R U N _ R O U T I N E --
-- --
-- B o d y --
-- --
-- --
-- Copyright (C) 2006-2011, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- --
-- --
-- --
-- --
-- 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/>. --
-- --
-- GNAT is maintained by AdaCore (http://www.adacore.com) --
-- --
------------------------------------------------------------------------------
with AUnit.Last_Chance_Handler; use AUnit.Last_Chance_Handler;
with AUnit.Time_Measure;
separate (AUnit.Simple_Test_Cases)
-- Version for run-time libraries that support exception handling via gcc
-- builtin setjmp/longjmp mechanism.
procedure Run_Routine
(Test : access Test_Case'Class;
Options : AUnit.Options.AUnit_Options;
R : in out Result'Class;
Outcome : out Status) is
Unexpected_Exception : Boolean := False;
Time : Time_Measure.Time := Time_Measure.Null_Time;
Res : Integer;
use Time_Measure;
function String_Compare (Str1, Str2 : String) return Boolean;
-- Compares two strings.
procedure Internal_Run_Test;
-- Wrapper for running the test case
--------------------
-- String_Compare --
--------------------
function String_Compare (Str1, Str2 : String) return Boolean is
begin
if Str1'Length /= Str2'Length then
return False;
end if;
for J in Str1'Range loop
if Str1 (J) /= Str2 (J - Str1'First + Str2'First) then
return False;
end if;
end loop;
return True;
end String_Compare;
-----------------------
-- Internal_Run_Test --
-----------------------
procedure Internal_Run_Test is
begin
if Options.Test_Case_Timer then
Start_Measure (Time);
end if;
AUnit.Simple_Test_Cases.Run_Test (Test.all);
if Options.Test_Case_Timer then
Stop_Measure (Time);
end if;
end Internal_Run_Test;
function Internal_Setjmp is new AUnit.Last_Chance_Handler.Gen_Setjmp
(Internal_Run_Test);
begin
-- Reset failure list to capture failed assertions for one routine
Clear_Failures (Test.all);
begin
Res := Internal_Setjmp;
if Res /= 0 then
if Options.Test_Case_Timer then
Stop_Measure (Time);
end if;
declare
Src : constant Message_String :=
AUnit.Last_Chance_Handler.Get_Exception_Message;
begin
if not String_Compare (Src.all, "aunit-assertions.adb:61") then
Unexpected_Exception := True;
Add_Error
(R,
Name (Test.all),
Routine_Name (Test.all),
Error =>
(Exception_Name => Get_Exception_Name,
Exception_Message => Src,
Traceback => null),
Elapsed => Time);
end if;
end;
end if;
end;
if not Unexpected_Exception and then not Has_Failures (Test.all) then
Outcome := Success;
Add_Success (R, Name (Test.all), Routine_Name (Test.all), Time);
else
Outcome := Failure;
declare
C : Failure_Iter := First_Failure (Test.all);
begin
while Has_Failure (C) loop
Add_Failure
(R,
Name (Test.all),
Routine_Name (Test.all),
Get_Failure (C),
Time);
Next (C);
end loop;
end;
end if;
end Run_Routine;
|
