MOM_unit_testing.F90

1! This file is part of MOM6, the Modular Ocean Model version 6.
2! See the LICENSE file for licensing information.
3! SPDX-License-Identifier: Apache-2.0
4
6
7use posix, only : chmod
8use posix, only : sigsetjmp
9use posix, only : sigjmp_buf
10
11use mom_coms, only : num_pes, sync_pes
12use mom_error_handler, only : is_root_pe
15
16implicit none ; private
17
18public :: string
19public :: create_test_file
20public :: delete_test_file
21public :: testsuite
22
23
24!> String container type
25type :: string
26 character(len=:), allocatable :: s
27 !< Internal character array of string
28end type string
29
30
31!> String constructor
32interface string
33 module procedure init_string_char
34 module procedure init_string_int
35end interface string
36
37
38!> A generalized instance of a unit test function
39type :: unittest
40 private
41 procedure(), nopass, pointer :: proc => null()
42 !< Unit test function/subroutine
43 procedure(), nopass, pointer :: cleanup => null()
44 !< Cleanup function to be run after proc
45 character(len=:), allocatable :: name
46 !< Unit test name (usually set to name of proc)
47 logical :: is_fatal
48 !< True if proc() is expected to fail
49contains
50 procedure :: run => run_unit_test
51 !< Run the unit test function, proc
52end type unittest
53
54
55!> Unit test constructor
56interface unittest
57 module procedure create_unit_test_basic
58 module procedure create_unit_test_full
59end interface unittest
60
61
62!> Collection of unit tests
63type :: testsuite
64 private
65 type(unittestnode), pointer :: head => null()
66 !< Head of the unit test linked list
67 type(unittestnode), pointer :: tail => null()
68 !< Tail of the unit test linked list (pre-allocated and unconfigured)
69
70 ! Public API
71 procedure(), nopass, pointer, public :: cleanup => null()
72 !< Default cleanup function for unit tests in suite
73contains
74 private
75 procedure :: add_basic => add_unit_test_basic
76 !< Add a unit test without a cleanup function
77 procedure :: add_full => add_unit_test_full
78 !< Add a unit test with an explicit cleanup function
79 generic, public :: add => add_basic, add_full
80 !< Add a unit test to the test suite
81 procedure, public :: run => run_test_suite
82 !< Run all unit tests in the suite
83end type testsuite
84
85
86!> TestSuite constructor
87interface testsuite
88 module procedure create_test_suite
89end interface testsuite
90
91
92!> UnitTest node of TestSuite's linked list
93type :: unittestnode
94 private
95 type(unittest), pointer :: test => null()
96 !< Node contents
97 type(unittestnode), pointer :: next => null()
98 !< Pointer to next node in list
99end type unittestnode
100
101contains
102
103!> Return a new unit test without a cleanup function
104function create_unit_test_basic(proc, name, fatal) result(test)
105 procedure() :: proc
106 !< Subroutine which defines the unit test
107 character(len=*), intent(in) :: name
108 !< Name of the unit test
109 logical, intent(in), optional :: fatal
110 !< True if the test is expected to raise a FATAL error
111 type(unittest) :: test
112
113 procedure(), pointer :: cleanup
114 cleanup => null()
115
116 test = create_unit_test_full(proc, name, fatal, cleanup)
117end function create_unit_test_basic
118
119
120!> Return a new unit test with an explicit cleanup function
121function create_unit_test_full(proc, name, fatal, cleanup) result(test)
122 procedure() :: proc
123 !< Subroutine which defines the unit test
124 character(len=*), intent(in) :: name
125 !< Name of the unit test
126 logical, optional :: fatal
127 !< True if the test is expected to raise a FATAL error
128 procedure() :: cleanup
129 !< Cleanup subroutine, called after test
130 type(unittest) :: test
131
132 test%proc => proc
133 test%name = name
134 test%is_fatal = .false.
135 if (present(fatal)) test%is_fatal = fatal
136 test%cleanup => cleanup
137end function create_unit_test_full
138
139
140!> Launch a unit test with a custom cleanup procedure
141subroutine run_unit_test(test)
142 class(unittest), intent(in) :: test
143
144 type(sigjmp_buf) :: env
145 integer :: rc
146
147 call sync_pes
148
149 ! FIXME: Some FATAL tests under MPI are unable to recover after jumpback, so
150 ! we disable these tests for now.
151 if (test%is_fatal .and. num_pes() > 1) return
152
153 if (test%is_fatal) then
154 rc = sigsetjmp(env, 1)
155 if (rc == 0) then
156 call disable_fatal_errors(env)
157 call test%proc
158 endif
160 else
161 call test%proc
162 endif
163
164 if (associated(test%cleanup)) call test%cleanup
165end subroutine run_unit_test
166
167
168!> Return a new test suite
169function create_test_suite() result(suite)
170 type(testsuite) :: suite
171
172 ! Setup the head node, but do not populate it
173 allocate(suite%head)
174 suite%tail => suite%head
175end function create_test_suite
176
177
178subroutine add_unit_test_basic(suite, test, name, fatal)
179 class(testsuite), intent(inout) :: suite
180 procedure() :: test
181 character(len=*), intent(in) :: name
182 logical, intent(in), optional :: fatal
183
184 procedure(), pointer :: cleanup
185
186 cleanup => null()
187 if (associated(suite%cleanup)) cleanup => suite%cleanup
188
189 call add_unit_test_full(suite, test, name, fatal, cleanup)
190end subroutine add_unit_test_basic
191
192
193subroutine add_unit_test_full(suite, test, name, fatal, cleanup)
194 class(testsuite), intent(inout) :: suite
195 procedure() :: test
196 character(len=*), intent(in) :: name
197 procedure() :: cleanup
198 logical, intent(in), optional :: fatal
199
200 type(unittest), pointer :: utest
201 type(unittestnode), pointer :: node
202
203 ! Populate the current tail
204 allocate(utest)
205 utest = unittest(test, name, fatal, cleanup)
206 suite%tail%test => utest
207
208 ! Create and append the new (empty) node, and update the tail
209 allocate(node)
210 suite%tail%next => node
211 suite%tail => node
212end subroutine add_unit_test_full
213
214
215subroutine run_test_suite(suite)
216 class(testsuite), intent(in) :: suite
217
218 type(unittestnode), pointer :: node
219
220 node => suite%head
221 do while(associated(node%test))
222 ! TODO: Capture FMS stdout/stderr
223 print '(/a)', "=== "//node%test%name
224
225 call node%test%run
226 if (associated(node%test%cleanup)) call node%test%cleanup
227
228 node => node%next
229 enddo
230end subroutine run_test_suite
231
232
233!> Initialize string with a character array.
234function init_string_char(c) result(str)
235 character(len=*), dimension(:), intent(in) :: c
236 !< List of character arrays
237 type(string), dimension(size(c)) :: str
238 !< String output
239
240 integer :: i
241
242 do i = 1, size(c)
243 str(i)%s = c(i)
244 enddo
245end function init_string_char
246
247
248!> Convert an integer to a string
249function init_string_int(n) result(str)
250 integer, intent(in) :: n
251 !< Integer input
252 type(string) :: str
253 !< String output
254
255 ! TODO: Estimate this with integer arithmetic
256 character(1 + floor(log10(real(abs(n)))) + (1 - sign(1, n))/2) :: chr
257
258 write(chr, '(i0)') n
259 str = string(chr)
260end function init_string_int
261
262
263!> Create a text file for unit testing
264subroutine create_test_file(filename, lines, mode)
265 character(len=*), intent(in) :: filename
266 !< Name of file to be created
267 type(string), intent(in), optional :: lines(:)
268 !< list of strings to write to file
269 integer, optional, intent(in) :: mode
270 !< Permissions of new file
271
272 integer :: param_unit
273 integer :: i
274 integer :: rc
275 logical :: sync
276
277 if (is_root_pe()) then
278 open(newunit=param_unit, file=filename, status='replace')
279 if (present(lines)) then
280 do i = 1, size(lines)
281 write(param_unit, '(a)') lines(i)%s
282 enddo
283 endif
284 close(param_unit)
285 if (present(mode)) rc = chmod(filename, mode)
286 endif
287 call sync_pes
288end subroutine create_test_file
289
290
291!> Delete a file created during testing
292subroutine delete_test_file(filename)
293 character(len=*), intent(in) :: filename
294 !< Name of file to be deleted
295
296 logical :: is_file, is_open
297 integer :: io_unit
298
299 if (is_root_pe()) then
300 inquire(file=filename, exist=is_file, opened=is_open, number=io_unit)
301
302 if (is_file) then
303 if (.not. is_open) open(newunit=io_unit, file=filename)
304 close(io_unit, status='delete')
305 endif
306 endif
307 call sync_pes
308end subroutine delete_test_file
309
310end module mom_unit_testing