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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
|
!> Define some procedures to automate collecting and launching of tests
module testsuite
use fpm_error, only : error_t, test_failed => fatal_error
implicit none
private
public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed
public :: select_test, select_suite
public :: check_string
public :: unittest_t, testsuite_t, error_t
abstract interface
!> Entry point for tests
subroutine test_interface(error)
import :: error_t
!> Error handling
type(error_t), allocatable, intent(out) :: error
end subroutine test_interface
end interface
!> Declaration of a unit test
type :: unittest_t
!> Name of the test
character(len=:), allocatable :: name
!> Entry point of the test
procedure(test_interface), pointer, nopass :: test => null()
!> Whether test is supposed to fail
logical :: should_fail = .false.
end type unittest_t
abstract interface
!> Collect all tests
subroutine collect_interface(testsuite)
import :: unittest_t
!> Collection of tests
type(unittest_t), allocatable, intent(out) :: testsuite(:)
end subroutine collect_interface
end interface
!> Collection of unit tests
type :: testsuite_t
!> Name of the testsuite
character(len=:), allocatable :: name
!> Entry point of the test
procedure(collect_interface), pointer, nopass :: collect => null()
end type testsuite_t
character(len=*), parameter :: fmt = '("#", *(1x, a))'
character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3)
contains
!> Driver for testsuite
subroutine run_testsuite(collect, unit, stat)
!> Collect tests
procedure(collect_interface) :: collect
!> Unit for IO
integer, intent(in) :: unit
!> Number of failed tests
integer, intent(inout) :: stat
type(unittest_t), allocatable :: testsuite(:)
integer :: ii
call collect(testsuite)
do ii = 1, size(testsuite)
write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') &
& "Starting", testsuite(ii)%name, "...", ii, size(testsuite)
call run_unittest(testsuite(ii), unit, stat)
end do
end subroutine run_testsuite
!> Driver for selective testing
subroutine run_selected(collect, name, unit, stat)
!> Collect tests
procedure(collect_interface) :: collect
!> Name of the selected test
character(len=*), intent(in) :: name
!> Unit for IO
integer, intent(in) :: unit
!> Number of failed tests
integer, intent(inout) :: stat
type(unittest_t), allocatable :: testsuite(:)
integer :: ii
call collect(testsuite)
ii = select_test(testsuite, name)
if (ii > 0 .and. ii <= size(testsuite)) then
call run_unittest(testsuite(ii), unit, stat)
else
write(unit, fmt) "Available tests:"
do ii = 1, size(testsuite)
write(unit, fmt) "-", testsuite(ii)%name
end do
stat = -huge(ii)
end if
end subroutine run_selected
!> Run a selected unit test
subroutine run_unittest(test, unit, stat)
!> Unit test
type(unittest_t), intent(in) :: test
!> Unit for IO
integer, intent(in) :: unit
!> Number of failed tests
integer, intent(inout) :: stat
type(error_t), allocatable :: error
call test%test(error)
if (allocated(error) .neqv. test%should_fail) then
if (test%should_fail) then
write(unit, fmt) indent, test%name, "[UNEXPECTED PASS]"
else
write(unit, fmt) indent, test%name, "[FAILED]"
end if
stat = stat + 1
else
if (test%should_fail) then
write(unit, fmt) indent, test%name, "[EXPECTED FAIL]"
else
write(unit, fmt) indent, test%name, "[PASSED]"
end if
end if
if (allocated(error)) then
write(unit, fmt) "Message:", error%message
end if
end subroutine run_unittest
!> Select a unit test from all available tests
function select_test(tests, name) result(pos)
!> Name identifying the test suite
character(len=*), intent(in) :: name
!> Available unit tests
type(unittest_t) :: tests(:)
!> Selected test suite
integer :: pos
integer :: it
pos = 0
do it = 1, size(tests)
if (name == tests(it)%name) then
pos = it
exit
end if
end do
end function select_test
!> Select a test suite from all available suites
function select_suite(suites, name) result(pos)
!> Name identifying the test suite
character(len=*), intent(in) :: name
!> Available test suites
type(testsuite_t) :: suites(:)
!> Selected test suite
integer :: pos
integer :: it
pos = 0
do it = 1, size(suites)
if (name == suites(it)%name) then
pos = it
exit
end if
end do
end function select_suite
!> Register a new unit test
function new_unittest(name, test, should_fail) result(self)
!> Name of the test
character(len=*), intent(in) :: name
!> Entry point for the test
procedure(test_interface) :: test
!> Whether test is supposed to error or not
logical, intent(in), optional :: should_fail
!> Newly registered test
type(unittest_t) :: self
self%name = name
self%test => test
if (present(should_fail)) self%should_fail = should_fail
end function new_unittest
!> Register a new testsuite
function new_testsuite(name, collect) result(self)
!> Name of the testsuite
character(len=*), intent(in) :: name
!> Entry point to collect tests
procedure(collect_interface) :: collect
!> Newly registered testsuite
type(testsuite_t) :: self
self%name = name
self%collect => collect
end function new_testsuite
!> Check a deferred length character variable against a reference value
subroutine check_string(error, actual, expected, name)
!> Error handling
type(error_t), allocatable, intent(out) :: error
!> Actual string value
character(len=:), allocatable, intent(in) :: actual
!> Expected string value
character(len=*), intent(in) :: expected
!> Name of the string to check
character(len=*), intent(in) :: name
if (.not.allocated(actual)) then
call test_failed(error, name//" is not set correctly")
return
end if
if (actual /= expected) then
call test_failed(error, name//" is "//actual// &
& " but should be "//expected)
end if
end subroutine check_string
end module testsuite
|
