diff options
| -rw-r--r-- | fpm/test/main.f90 | 99 | ||||
| -rw-r--r-- | fpm/test/testsuite.f90 | 180 |
2 files changed, 239 insertions, 40 deletions
diff --git a/fpm/test/main.f90 b/fpm/test/main.f90 index f9d0941..0e4f156 100644 --- a/fpm/test/main.f90 +++ b/fpm/test/main.f90 @@ -1,36 +1,97 @@ !> Driver for unit testing program fpm_testing use, intrinsic :: iso_fortran_env, only : error_unit - use testsuite, only : run_testsuite + use testsuite, only : run_testsuite, new_testsuite, testsuite_t, & + & select_suite, run_selected use test_toml, only : collect_toml use test_manifest, only : collect_manifest use test_source_parsing, only : collect_source_parsing implicit none - integer :: stat + integer :: stat, is + character(len=:), allocatable :: suite_name, test_name + type(testsuite_t), allocatable :: testsuite(:) character(len=*), parameter :: fmt = '("#", *(1x, a))' - write(error_unit, fmt) "Testing:", "fpm_toml" - call run_testsuite(collect_toml, error_unit, stat) + testsuite = [ & + & new_testsuite("fpm_toml", collect_toml), & + & new_testsuite("fpm_manifest", collect_manifest), & + & new_testsuite("fpm_source_parsing", collect_source_parsing) & + & ] - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "tests failed!" - error stop 1 - end if + call get_argument(1, suite_name) + call get_argument(2, test_name) + + if (allocated(suite_name)) then + is = select_suite(testsuite, suite_name) + if (is > 0 .and. is <= size(testsuite)) then + if (allocated(test_name)) then + write(error_unit, fmt) "Suite:", testsuite(is)%name + call run_selected(testsuite(is)%collect, test_name, error_unit, stat) + if (stat == -1) then + error stop 1 + end if + else + write(error_unit, fmt) "Testing:", testsuite(is)%name + call run_testsuite(testsuite(is)%collect, error_unit, stat) + end if - write(error_unit, fmt) "Testing:", "fpm_manifest" - call run_testsuite(collect_manifest, error_unit, stat) + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop 1 + end if + else + write(error_unit, fmt) "Available testsuites" + do is = 1, size(testsuite) + write(error_unit, fmt) "-", testsuite(is)%name + end do + error stop 1 + end if + else + do is = 1, size(testsuite) + write(error_unit, fmt) "Testing:", testsuite(is)%name + call run_testsuite(testsuite(is)%collect, error_unit, stat) - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "tests failed!" - error stop 1 + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop 1 + end if + end do end if - write(error_unit, fmt) "Testing:", "fpm_sources (parsing)" - call run_testsuite(collect_source_parsing, error_unit, stat) - if (stat > 0) then - write(error_unit, '(i0, 1x, a)') stat, "tests failed!" - error stop 1 - end if +contains + + + !> Obtain the command line argument at a given index + subroutine get_argument(idx, arg) + + !> Index of command line argument, range [0:command_argument_count()] + integer, intent(in) :: idx + + !> Command line argument + character(len=:), allocatable, intent(out) :: arg + + integer :: length, stat + + call get_command_argument(idx, length=length, status=stat) + if (stat /= 0) then + return + endif + + allocate(character(len=length) :: arg, stat=stat) + if (stat /= 0) then + return + endif + + if (length > 0) then + call get_command_argument(idx, arg, status=stat) + if (stat /= 0) then + deallocate(arg) + return + end if + end if + + end subroutine get_argument + end program fpm_testing diff --git a/fpm/test/testsuite.f90 b/fpm/test/testsuite.f90 index 9b69032..4e46217 100644 --- a/fpm/test/testsuite.f90 +++ b/fpm/test/testsuite.f90 @@ -4,9 +4,10 @@ module testsuite implicit none private - public :: run_testsuite, new_unittest, test_failed + public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed + public :: select_test, select_suite public :: check_string - public :: unittest_t, error_t + public :: unittest_t, testsuite_t, error_t abstract interface @@ -48,6 +49,22 @@ module testsuite 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 @@ -64,9 +81,6 @@ contains integer, intent(out) :: stat type(unittest_t), allocatable :: testsuite(:) - character(len=*), parameter :: fmt = '("#", *(1x, a))' - character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3) - type(error_t), allocatable :: error integer :: ii stat = 0 @@ -76,27 +90,133 @@ contains do ii = 1, size(testsuite) write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') & & "Starting", testsuite(ii)%name, "...", ii, size(testsuite) - call testsuite(ii)%test(error) - if (allocated(error) .neqv. testsuite(ii)%should_fail) then - if (testsuite(ii)%should_fail) then - write(unit, fmt) indent, testsuite(ii)%name, "[UNEXPECTED PASS]" - else - write(unit, fmt) indent, testsuite(ii)%name, "[FAILED]" - end if - stat = stat + 1 + 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(out) :: stat + + type(unittest_t), allocatable :: testsuite(:) + integer :: ii + + stat = 0 + + 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 = -1 + 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 - if (testsuite(ii)%should_fail) then - write(unit, fmt) indent, testsuite(ii)%name, "[EXPECTED FAIL]" - else - write(unit, fmt) indent, testsuite(ii)%name, "[PASSED]" - end if + write(unit, fmt) indent, test%name, "[FAILED]" end if - if (allocated(error)) then - write(unit, fmt) "Message:", error%message + 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 subroutine run_testsuite + 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 @@ -121,6 +241,24 @@ contains 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) |