Skip to content

Commit 4a5ecae

Browse files
awvwgkawvwgk
committed
Allow selective testing of single suites and tests
1 parent c492ac3 commit 4a5ecae

File tree

2 files changed

+239
-40
lines changed

2 files changed

+239
-40
lines changed

‎fpm/test/main.f90

Lines changed: 80 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -1,36 +1,97 @@
11
!> Driver for unit testing
22
program fpm_testing
33
use, intrinsic :: iso_fortran_env, only : error_unit
4-
use testsuite, only : run_testsuite
4+
use testsuite, only : run_testsuite, new_testsuite, testsuite_t, &
5+
& select_suite, run_selected
56
use test_toml, only : collect_toml
67
use test_manifest, only : collect_manifest
78
use test_source_parsing, only : collect_source_parsing
89
implicit none
9-
integer :: stat
10+
integer :: stat, is
11+
character(len=:), allocatable :: suite_name, test_name
12+
type(testsuite_t), allocatable :: testsuite(:)
1013
character(len=*), parameter :: fmt = '("#", *(1x, a))'
1114

12-
write(error_unit, fmt) "Testing:", "fpm_toml"
13-
call run_testsuite(collect_toml, error_unit, stat)
15+
testsuite = [ &
16+
& new_testsuite("fpm_toml", collect_toml), &
17+
& new_testsuite("fpm_manifest", collect_manifest), &
18+
& new_testsuite("fpm_source_parsing", collect_source_parsing) &
19+
& ]
1420

15-
if (stat > 0) then
16-
write(error_unit, '(i0, 1x, a)') stat, "tests failed!"
17-
error stop 1
18-
end if
21+
call get_argument(1, suite_name)
22+
call get_argument(2, test_name)
23+
24+
if (allocated(suite_name)) then
25+
is = select_suite(testsuite, suite_name)
26+
if (is > 0 .and. is <= size(testsuite)) then
27+
if (allocated(test_name)) then
28+
write(error_unit, fmt) "Suite:", testsuite(is)%name
29+
call run_selected(testsuite(is)%collect, test_name, error_unit, stat)
30+
if (stat == -1) then
31+
error stop 1
32+
end if
33+
else
34+
write(error_unit, fmt) "Testing:", testsuite(is)%name
35+
call run_testsuite(testsuite(is)%collect, error_unit, stat)
36+
end if
1937

20-
write(error_unit, fmt) "Testing:", "fpm_manifest"
21-
call run_testsuite(collect_manifest, error_unit, stat)
38+
if (stat > 0) then
39+
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
40+
error stop 1
41+
end if
42+
else
43+
write(error_unit, fmt) "Available testsuites"
44+
do is = 1, size(testsuite)
45+
write(error_unit, fmt) "-", testsuite(is)%name
46+
end do
47+
error stop 1
48+
end if
49+
else
50+
do is = 1, size(testsuite)
51+
write(error_unit, fmt) "Testing:", testsuite(is)%name
52+
call run_testsuite(testsuite(is)%collect, error_unit, stat)
2253

23-
if (stat > 0) then
24-
write(error_unit, '(i0, 1x, a)') stat, "tests failed!"
25-
error stop 1
54+
if (stat > 0) then
55+
write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
56+
error stop 1
57+
end if
58+
end do
2659
end if
2760

28-
write(error_unit, fmt) "Testing:", "fpm_sources (parsing)"
29-
call run_testsuite(collect_source_parsing, error_unit, stat)
3061

31-
if (stat > 0) then
32-
write(error_unit, '(i0, 1x, a)') stat, "tests failed!"
33-
error stop 1
34-
end if
62+
contains
63+
64+
65+
!> Obtain the command line argument at a given index
66+
subroutine get_argument(idx, arg)
67+
68+
!> Index of command line argument, range [0:command_argument_count()]
69+
integer, intent(in) :: idx
70+
71+
!> Command line argument
72+
character(len=:), allocatable, intent(out) :: arg
73+
74+
integer :: length, stat
75+
76+
call get_command_argument(idx, length=length, status=stat)
77+
if (stat /= 0) then
78+
return
79+
endif
80+
81+
allocate(character(len=length) :: arg, stat=stat)
82+
if (stat /= 0) then
83+
return
84+
endif
85+
86+
if (length > 0) then
87+
call get_command_argument(idx, arg, status=stat)
88+
if (stat /= 0) then
89+
deallocate(arg)
90+
return
91+
end if
92+
end if
93+
94+
end subroutine get_argument
95+
3596

3697
end program fpm_testing

‎fpm/test/testsuite.f90

Lines changed: 159 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -4,9 +4,10 @@ module testsuite
44
implicit none
55
private
66

7-
public :: run_testsuite, new_unittest, test_failed
7+
public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed
8+
public :: select_test, select_suite
89
public :: check_string
9-
public :: unittest_t, error_t
10+
public :: unittest_t, testsuite_t, error_t
1011

1112

1213
abstract interface
@@ -48,6 +49,22 @@ end subroutine collect_interface
4849
end interface
4950

5051

52+
!> Collection of unit tests
53+
type :: testsuite_t
54+
55+
!> Name of the testsuite
56+
character(len=:), allocatable :: name
57+
58+
!> Entry point of the test
59+
procedure(collect_interface), pointer, nopass :: collect => null()
60+
61+
end type testsuite_t
62+
63+
64+
character(len=*), parameter :: fmt = '("#", *(1x, a))'
65+
character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3)
66+
67+
5168
contains
5269

5370

@@ -64,9 +81,6 @@ subroutine run_testsuite(collect, unit, stat)
6481
integer, intent(out) :: stat
6582

6683
type(unittest_t), allocatable :: testsuite(:)
67-
character(len=*), parameter :: fmt = '("#", *(1x, a))'
68-
character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3)
69-
type(error_t), allocatable :: error
7084
integer :: ii
7185

7286
stat = 0
@@ -76,27 +90,133 @@ subroutine run_testsuite(collect, unit, stat)
7690
do ii = 1, size(testsuite)
7791
write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') &
7892
& "Starting", testsuite(ii)%name, "...", ii, size(testsuite)
79-
call testsuite(ii)%test(error)
80-
if (allocated(error) .neqv. testsuite(ii)%should_fail) then
81-
if (testsuite(ii)%should_fail) then
82-
write(unit, fmt) indent, testsuite(ii)%name, "[UNEXPECTED PASS]"
83-
else
84-
write(unit, fmt) indent, testsuite(ii)%name, "[FAILED]"
85-
end if
86-
stat = stat + 1
93+
call run_unittest(testsuite(ii), unit, stat)
94+
end do
95+
96+
end subroutine run_testsuite
97+
98+
99+
!> Driver for selective testing
100+
subroutine run_selected(collect, name, unit, stat)
101+
102+
!> Collect tests
103+
procedure(collect_interface) :: collect
104+
105+
!> Name of the selected test
106+
character(len=*), intent(in) :: name
107+
108+
!> Unit for IO
109+
integer, intent(in) :: unit
110+
111+
!> Number of failed tests
112+
integer, intent(out) :: stat
113+
114+
type(unittest_t), allocatable :: testsuite(:)
115+
integer :: ii
116+
117+
stat = 0
118+
119+
call collect(testsuite)
120+
121+
ii = select_test(testsuite, name)
122+
123+
if (ii > 0 .and. ii <= size(testsuite)) then
124+
call run_unittest(testsuite(ii), unit, stat)
125+
else
126+
write(unit, fmt) "Available tests:"
127+
do ii = 1, size(testsuite)
128+
write(unit, fmt) "-", testsuite(ii)%name
129+
end do
130+
stat = -1
131+
end if
132+
133+
end subroutine run_selected
134+
135+
136+
!> Run a selected unit test
137+
subroutine run_unittest(test, unit, stat)
138+
139+
!> Unit test
140+
type(unittest_t), intent(in) :: test
141+
142+
!> Unit for IO
143+
integer, intent(in) :: unit
144+
145+
!> Number of failed tests
146+
integer, intent(inout) :: stat
147+
148+
type(error_t), allocatable :: error
149+
150+
call test%test(error)
151+
if (allocated(error) .neqv. test%should_fail) then
152+
if (test%should_fail) then
153+
write(unit, fmt) indent, test%name, "[UNEXPECTED PASS]"
87154
else
88-
if (testsuite(ii)%should_fail) then
89-
write(unit, fmt) indent, testsuite(ii)%name, "[EXPECTED FAIL]"
90-
else
91-
write(unit, fmt) indent, testsuite(ii)%name, "[PASSED]"
92-
end if
155+
write(unit, fmt) indent, test%name, "[FAILED]"
93156
end if
94-
if (allocated(error)) then
95-
write(unit, fmt) "Message:", error%message
157+
stat = stat + 1
158+
else
159+
if (test%should_fail) then
160+
write(unit, fmt) indent, test%name, "[EXPECTED FAIL]"
161+
else
162+
write(unit, fmt) indent, test%name, "[PASSED]"
163+
end if
164+
end if
165+
if (allocated(error)) then
166+
write(unit, fmt) "Message:", error%message
167+
end if
168+
169+
end subroutine run_unittest
170+
171+
172+
!> Select a unit test from all available tests
173+
function select_test(tests, name) result(pos)
174+
175+
!> Name identifying the test suite
176+
character(len=*), intent(in) :: name
177+
178+
!> Available unit tests
179+
type(unittest_t) :: tests(:)
180+
181+
!> Selected test suite
182+
integer :: pos
183+
184+
integer :: it
185+
186+
pos = 0
187+
do it = 1, size(tests)
188+
if (name == tests(it)%name) then
189+
pos = it
190+
exit
96191
end if
97192
end do
98193

99-
end subroutine run_testsuite
194+
end function select_test
195+
196+
197+
!> Select a test suite from all available suites
198+
function select_suite(suites, name) result(pos)
199+
200+
!> Name identifying the test suite
201+
character(len=*), intent(in) :: name
202+
203+
!> Available test suites
204+
type(testsuite_t) :: suites(:)
205+
206+
!> Selected test suite
207+
integer :: pos
208+
209+
integer :: it
210+
211+
pos = 0
212+
do it = 1, size(suites)
213+
if (name == suites(it)%name) then
214+
pos = it
215+
exit
216+
end if
217+
end do
218+
219+
end function select_suite
100220

101221

102222
!> Register a new unit test
@@ -121,6 +241,24 @@ function new_unittest(name, test, should_fail) result(self)
121241
end function new_unittest
122242

123243

244+
!> Register a new testsuite
245+
function new_testsuite(name, collect) result(self)
246+
247+
!> Name of the testsuite
248+
character(len=*), intent(in) :: name
249+
250+
!> Entry point to collect tests
251+
procedure(collect_interface) :: collect
252+
253+
!> Newly registered testsuite
254+
type(testsuite_t) :: self
255+
256+
self%name = name
257+
self%collect => collect
258+
259+
end function new_testsuite
260+
261+
124262
!> Check a deferred length character variable against a reference value
125263
subroutine check_string(error, actual, expected, name)
126264

0 commit comments

Comments
 (0)