diff --git a/README.rst b/README.rst index 05a5152..e0198a6 100644 --- a/README.rst +++ b/README.rst @@ -24,7 +24,7 @@ systems. - integration with the `fpm `_, `CMake `_ and `Meson `_ build systems. -Detailed **documentation** is available on the `Fortuno documentation +**Documentation** is available on the `Fortuno documentation `_ page. You can also have a look at the examples in the `example folder `_. diff --git a/src/fortuno/argumentparser.f90 b/src/fortuno/argumentparser.f90 index 9133e37..79393d8 100644 --- a/src/fortuno/argumentparser.f90 +++ b/src/fortuno/argumentparser.f90 @@ -60,6 +60,13 @@ module fortuno_argumentparser end type argument_value + ! Workaround:gfortran:13.2 + ! Needs user defined structure constructor to deal with class(*) field + interface argument_value + module procedure new_argument_value + end interface + + !> Collection of all argument values obtained after command line had been prased type :: argument_values private @@ -174,7 +181,7 @@ subroutine argument_parser_parse_args(this, argumentvalues, logger, exitcode) if (matches) then select case (argdef%argtype) case (argtypes%bool) - argumentvalues%argvals = [argumentvalues%argvals, argument_value(name=argdef%name)] + argumentvalues%argvals = [argumentvalues%argvals, argument_value(argdef%name)] case default call logger%log_error("Unknown argument type") exitcode = 1 @@ -194,15 +201,8 @@ subroutine argument_parser_parse_args(this, argumentvalues, logger, exitcode) associate (argdef => this%argdefs(nargdefs)) ! If the last argdef was not an option, store all position arguments under this name if (.not. allocated(argdef%longopt) .and. argdef%shortopt == "") then - ! argumentvalues%argvals = [argumentvalues%argvals,& - ! & argument_value(name=argdef%name, argval=string_list(posargs))] - ! Workaround:gfortran:13.2 - block - class(*), allocatable :: tmp - tmp = string_list(posargs) - argumentvalues%argvals = [argumentvalues%argvals,& - & argument_value(name=argdef%name, argval=tmp)] - end block + argumentvalues%argvals = [argumentvalues%argvals,& + & argument_value(argdef%name, argval=string_list(posargs))] else if (size(posargs) > 1) then call logger%log_error("Superfluous positional arguments found") exitcode = 1 @@ -270,6 +270,20 @@ subroutine argument_values_get_value_stringlist(this, name, val) end subroutine argument_values_get_value_stringlist + !> User defined structure constructor for argument_value + function new_argument_value(name, argval) result(this) + character(*), intent(in) :: name + class(*), optional, intent(in) :: argval + type(argument_value) :: this + + this%name = name + if (present(argval)) then + allocate(this%argval, source=argval) + end if + + end function new_argument_value + + !! Returns the command line arguments as an array of strings. subroutine get_command_line_args_(cmdargs) type(string), allocatable :: cmdargs(:) diff --git a/src/fortuno/testdriver.f90 b/src/fortuno/testdriver.f90 index d4a3ecf..099441b 100644 --- a/src/fortuno/testdriver.f90 +++ b/src/fortuno/testdriver.f90 @@ -82,7 +82,7 @@ end subroutine test_runner_run_test end interface - !! Data item stored for each test (name and identifier). + !! Data item stored for each test when building a plain non-nested list of all test items. type :: test_data ! Unique integer identifier (path) of the test object @@ -97,7 +97,7 @@ end subroutine test_runner_run_test end type test_data - !! Minimalistic automatically growing array of test_data_ items. + !! Minimalistic automatically growing array of test_data items. type :: test_data_container private type(test_data), pointer, public :: testdata(:) => null() @@ -108,19 +108,29 @@ end subroutine test_runner_run_test end type test_data_container + !! Selection related reversible mapping data + !! + !! Forward mapping: selection index to test/suite index within container + !! Reverse mapping: test/suite index within container to selection index + !! + type :: reversible_mapping + integer, allocatable :: fwd(:), rev(:) + end type reversible_mapping + + !> App for driving serial tests through command line app type :: test_driver private !> Result of a test drive, after run_tests() had been invoked + type(drive_result), public :: driveresult + class(test_runner), allocatable :: runner class(context_factory), allocatable :: ctxfactory class(test_logger), allocatable :: logger - type(drive_result), public :: driveresult type(test_item), allocatable :: testitems(:) type(test_data_container) :: testdatacont type(test_data_container) :: suitedatacont - integer, allocatable :: selectedsuites(:) - integer, allocatable :: selectedtests(:) + type(reversible_mapping) :: suiteselection, testselection contains procedure :: register_tests => test_driver_register_tests procedure :: run_tests => test_driver_run_tests @@ -141,6 +151,7 @@ end subroutine test_runner_run_test contains + !> Initializes a test driver instance subroutine init_test_driver(this, ctxfactory, runner) @@ -173,11 +184,11 @@ subroutine test_driver_register_tests(this, testitems, selections) this%testitems = testitems call init_test_data_container(this%suitedatacont, 100) - call init_test_data_container(this%testdatacont, 1000) + call init_test_data_container(this%testdatacont, 5000) call build_test_data_(this%testitems, "", [integer ::], [integer ::], this%testdatacont,& & this%suitedatacont) call get_selected_suites_and_tests_(this%suitedatacont%testdata, this%testdatacont%testdata,& - & this%selectedsuites, this%selectedtests, selections) + & this%suiteselection, this%testselection, selections) end subroutine test_driver_register_tests @@ -191,19 +202,18 @@ subroutine test_driver_run_tests(this, logger) !> Logger for reporting events class(test_logger), intent(inout) :: logger - call init_drive_result(this%driveresult, size(this%selectedsuites), size(this%selectedtests)) + call init_drive_result(this%driveresult, size(this%suiteselection%fwd),& + & size(this%testselection%fwd)) call logger%start_drive() call logger%start_tests() - call run_tests_(this%testitems, testtypes%suitesetup, this%suitedatacont%testdata,& - & this%selectedsuites, this%driveresult%suiteresults(1, :), this%ctxfactory, this%runner,& - & logger) - call run_tests_(this%testitems, testtypes%testrun, this%testdatacont%testdata,& - & this%selectedtests, this%driveresult%testresults, this%ctxfactory, this%runner, logger,& - & this%driveresult%suiteresults(1, :)) - call run_tests_(this%testitems, testtypes%suiteteardown, this%suitedatacont%testdata,& - & this%selectedsuites, this%driveresult%suiteresults(2, :), this%ctxfactory, this%runner,& - & logger, this%driveresult%suiteresults(1, :)) + call run_suite_initializers_finalizers_(.true., this%testitems, this%suitedatacont%testdata,& + & this%suiteselection, this%driveresult%suiteresults, this%ctxfactory, this%runner, logger) + call run_tests_(this%testitems, this%suiteselection, this%driveresult%suiteresults(1, :),& + & this%testdatacont%testdata, this%testselection, this%driveresult%testresults,& + & this%ctxfactory, this%runner, logger) + call run_suite_initializers_finalizers_(.false., this%testitems, this%suitedatacont%testdata,& + this%suiteselection, this%driveresult%suiteresults, this%ctxfactory, this%runner, logger) call logger%end_tests() call this%driveresult%calculate_stats() call logger%log_drive_result(this%driveresult) @@ -221,67 +231,113 @@ subroutine test_driver_get_test_names(this, testnames) !> Name of all tests type(string), allocatable :: testnames(:) - integer :: ntests, itest + integer :: nselect, iselect - ntests = size(this%selectedtests) - allocate(testnames(ntests)) - do itest = 1, ntests - testnames(itest)%content = this%testdatacont%testdata(this%selectedtests(itest))%name + nselect = size(this%testselection%fwd) + allocate(testnames(nselect)) + do iselect = 1, nselect + testnames(iselect)%content = this%testdatacont%testdata(this%testselection%fwd(iselect))%name end do end subroutine test_driver_get_test_names - !! Executes various test objects. - subroutine run_tests_(testitems, testtype, testdatas, selected, testresults, ctxfactory, runner,& - & logger, dependencyresults) + subroutine run_suite_initializers_finalizers_(initializer, testitems, suitedatas, suiteselection,& + & suiteresults, ctxfactory, runner, logger) + logical, intent(in) :: initializer type(test_item), intent(inout) :: testitems(:) - integer, intent(in) :: testtype - type(test_data), intent(inout) :: testdatas(:) - integer, intent(in) :: selected(:) - type(test_result), target, intent(inout) :: testresults(:) + type(test_data), intent(inout) :: suitedatas(:) + type(reversible_mapping), intent(in) :: suiteselection + type(test_result), intent(inout) :: suiteresults(:,:) class(context_factory), intent(inout) :: ctxfactory class(test_runner), intent(inout) :: runner class(test_logger), intent(inout) :: logger - type(test_result), optional, target, intent(in) :: dependencyresults(:) - type(test_result), pointer :: depresults(:) class(test_context), allocatable :: ctx character(:), allocatable :: repr - integer :: depstatus - integer :: iselect + integer :: iselect, idata, depstatus, iresult - if (present(dependencyresults)) then - depresults => dependencyresults + if (initializer) then + iresult = 1 else - depresults => testresults + iresult = 2 end if - do iselect = 1, size(selected) - associate (testdata => testdatas(selected(iselect)), testresult => testresults(iselect)) + do iselect = 1, size(suiteselection%fwd) + idata = suiteselection%fwd(iselect) + associate (suitedata => suitedatas(idata), suiteresult => suiteresults(:, iselect)) + suiteresult(iresult)%name = suitedata%name + ! Dependencies in result should point to entries in suite result array + suiteresult(iresult)%dependencies = suiteselection%rev(suitedata%dependencies) + + if (initializer) then + ! Initializer depends on the status of the initializaiton of the closest dependency. + if (size(suiteresult(1)%dependencies) > 0) then + depstatus = suiteresults(1, suiteresult(1)%dependencies(1))%status + else + depstatus = teststatus%succeeded + end if + else + ! Finalizer depends on the status of the initializer of the same suite + depstatus = suiteresult(1)%status + end if + + if (depstatus == teststatus%succeeded) then + call ctxfactory%create_context(ctx) + call initialize_finalize_suite_(testitems, suitedata%identifier, initializer, ctx,& + & runner, repr) + suiteresult(iresult)%status = ctx%status() + call ctx%pop_failure_info(suiteresult(iresult)%failureinfo) + deallocate(ctx) + else + if (depstatus == teststatus%skipped) then + suiteresult(iresult)%status = teststatus%skipped + else + suiteresult(iresult)%status = teststatus%ignored + end if + end if + + call set_repr_name_(suiteresults(iresult, :), iselect, repr) + if (allocated(repr)) deallocate(repr) + + call logger%log_test_result(testtypes%suitesetup, suiteresult(iresult)) + end associate + end do + + end subroutine run_suite_initializers_finalizers_ + + + subroutine run_tests_(testitems, suiteselection, suiteinitresults, testdatas, testselection,& + & testresults, ctxfactory, runner, logger) + type(test_item), intent(inout) :: testitems(:) + type(reversible_mapping), intent(in) :: suiteselection + type(test_result), intent(in) :: suiteinitresults(:) + type(test_data), intent(inout) :: testdatas(:) + type(reversible_mapping), intent(in) :: testselection + type(test_result), intent(inout) :: testresults(:) + class(context_factory), intent(inout) :: ctxfactory + class(test_runner), intent(inout) :: runner + class(test_logger), intent(inout) :: logger + + class(test_context), allocatable :: ctx + character(:), allocatable :: repr + integer :: iselect, idata, depstatus + + do iselect = 1, size(testselection%fwd) + idata = testselection%fwd(iselect) + associate (testdata => testdatas(idata), testresult => testresults(iselect)) testresult%name = testdata%name - testresult%dependencies = testdata%dependencies + ! Dependencies in results should point to entries in suite result array + testresult%dependencies = suiteselection%rev(testdata%dependencies) - if (testtype == testtypes%suiteteardown) then - depstatus = depresults(iselect)%status - else if (size(testdata%dependencies) > 0) then - depstatus = depresults(testdata%dependencies(1))%status + if (size(testresult%dependencies) > 0) then + depstatus = suiteinitresults(testresult%dependencies(1))%status else depstatus = teststatus%succeeded end if - if (depstatus == teststatus%succeeded) then call ctxfactory%create_context(ctx) - select case (testtype) - case (testtypes%suitesetup) - call initialize_finalize_suite_(testitems, testdata%identifier, .true., ctx, runner,& - & repr) - case (testtypes%testrun) - call run_test_(testitems, testdata%identifier, ctx, runner, repr) - case (testtypes%suiteteardown) - call initialize_finalize_suite_(testitems, testdata%identifier, .false., ctx, runner,& - & repr) - end select + call run_test_(testitems, testdata%identifier, ctx, runner, repr) testresult%status = ctx%status() call ctx%pop_failure_info(testresult%failureinfo) deallocate(ctx) @@ -293,17 +349,10 @@ subroutine run_tests_(testitems, testtype, testdatas, selected, testresults, ctx end if end if - select case (testtype) - case (testtypes%suitesetup) - call set_repr_name_(testresults, iselect, repr) - case (testtypes%testrun) - call set_repr_name_(testresults, iselect, repr, depresults) - case (testtypes%suiteteardown) - testresult%reprname = depresults(iselect)%reprname - end select + call set_repr_name_(testresults, iselect, repr, suiteinitresults) if (allocated(repr)) deallocate(repr) - call logger%log_test_result(testtype, testresult) + call logger%log_test_result(testtypes%testrun, testresult) end associate end do @@ -384,7 +433,7 @@ subroutine test_data_container_append(this, testdata) type(test_data), pointer :: buffer(:) if (size(this%storage_) == size(this%testdata)) then - newsize = int(size(this%storage_) * 1.4) + newsize = max(int(size(this%storage_) * 1.4), size(this%storage_) + 2) allocate(buffer(newsize)) buffer(1 : size(this%storage_)) = this%storage_ deallocate(this%storage_) @@ -495,10 +544,10 @@ end subroutine set_repr_name_ !! Returns indices of selected suites and tests. - subroutine get_selected_suites_and_tests_(suitedata, testdata, selectedsuites, selectedtests,& + subroutine get_selected_suites_and_tests_(suitedata, testdata, suiteselection, testselection,& & selections) type(test_data), intent(in) :: suitedata(:), testdata(:) - integer, allocatable, intent(out) :: selectedsuites(:), selectedtests(:) + type(reversible_mapping), intent(out) :: suiteselection, testselection type(test_selection), optional, intent(in) :: selections(:) logical, allocatable :: testmask(:), suitemask(:) @@ -507,11 +556,15 @@ subroutine get_selected_suites_and_tests_(suitedata, testdata, selectedsuites, s integer :: selectnamelen integer :: ii - selectedsuites = [(ii, ii = 1, size(suitedata))] - selectedtests = [(ii, ii = 1, size(testdata))] hasselection = present(selections) if (hasselection) hasselection = size(selections) > 0 - if (.not. hasselection) return + if (.not. hasselection) then + suiteselection%fwd = [(ii, ii = 1, size(suitedata))] + suiteselection%rev = suiteselection%fwd + testselection%fwd = [(ii, ii = 1, size(testdata))] + testselection%rev = testselection%fwd + return + end if allocate(testmask(size(testdata))) ! If first option is an exclusion, include all tests by default otherwise exclude them. @@ -541,9 +594,24 @@ subroutine get_selected_suites_and_tests_(suitedata, testdata, selectedsuites, s if (testmask(itest)) suitemask(testdata(itest)%dependencies) = .true. end do - selectedsuites = pack(selectedsuites, suitemask) - selectedtests = pack(selectedtests, testmask) + call get_rev_map_from_mask_(suitemask, suiteselection) + call get_rev_map_from_mask_(testmask, testselection) end subroutine get_selected_suites_and_tests_ + + subroutine get_rev_map_from_mask_(mask, mapping) + logical, intent(in) :: mask(:) + type(reversible_mapping), intent(out) :: mapping + + integer :: ii + + mapping%fwd = pack([(ii, ii = 1, size(mask))], mask) + allocate(mapping%rev(size(mask)), source=0) + do ii = 1, size(mapping%fwd) + mapping%rev(mapping%fwd(ii)) = ii + end do + + end subroutine get_rev_map_from_mask_ + end module fortuno_testdriver