From a1b12f94f51617dcb125b816a92064ea63c6f755 Mon Sep 17 00:00:00 2001 From: fortuno-repos Date: Sat, 28 Sep 2024 12:19:27 +0000 Subject: [PATCH] Update from https://github.com/fortuno-repos/fortuno/commit/672a3981f6b0200d03ccce287c7722c5172e9636 --- .github/workflows/ci.yml | 45 ++ fpm.toml | 11 + src/fortuno.f90 | 20 + src/fortuno/argumentparser.f90 | 427 +++++++++++++++ src/fortuno/basetypes.f90 | 244 +++++++++ src/fortuno/chartypes.f90 | 223 ++++++++ src/fortuno/checkers.f90 | 62 +++ src/fortuno/cmdapp.f90 | 190 +++++++ src/fortuno/consolelogger.f90 | 421 +++++++++++++++ src/fortuno/testcontext.f90 | 348 ++++++++++++ src/fortuno/testdriver.f90 | 643 +++++++++++++++++++++++ src/fortuno/testinfo.f90 | 222 ++++++++ src/fortuno/testlogger.f90 | 151 ++++++ src/fortuno/utils.f90 | 126 +++++ src/fortuno/version.f90 | 30 ++ src/fortuno_serial.f90 | 17 + src/fortuno_serial/serialbasetypes.f90 | 98 ++++ src/fortuno_serial/serialcase.f90 | 60 +++ src/fortuno_serial/serialcmdapp.f90 | 73 +++ src/fortuno_serial/serialconlogger.f90 | 18 + src/fortuno_serial/serialcontext.f90 | 60 +++ src/fortuno_serial/serialdriver.f90 | 119 +++++ src/fortuno_serial/serialglobalctx.f90 | 135 +++++ src/fortuno_serial/serialsuite.f90 | 31 ++ test/export/serial/app/testapp.f90 | 41 ++ test/export/serial/app/testapp_fpp.F90 | 43 ++ test/export/serial/app/testapp_fypp.fypp | 43 ++ test/export/serial/fpm.toml | 27 + 28 files changed, 3928 insertions(+) create mode 100644 .github/workflows/ci.yml create mode 100644 fpm.toml create mode 100644 src/fortuno.f90 create mode 100644 src/fortuno/argumentparser.f90 create mode 100644 src/fortuno/basetypes.f90 create mode 100644 src/fortuno/chartypes.f90 create mode 100644 src/fortuno/checkers.f90 create mode 100644 src/fortuno/cmdapp.f90 create mode 100644 src/fortuno/consolelogger.f90 create mode 100644 src/fortuno/testcontext.f90 create mode 100644 src/fortuno/testdriver.f90 create mode 100644 src/fortuno/testinfo.f90 create mode 100644 src/fortuno/testlogger.f90 create mode 100644 src/fortuno/utils.f90 create mode 100644 src/fortuno/version.f90 create mode 100644 src/fortuno_serial.f90 create mode 100644 src/fortuno_serial/serialbasetypes.f90 create mode 100644 src/fortuno_serial/serialcase.f90 create mode 100644 src/fortuno_serial/serialcmdapp.f90 create mode 100644 src/fortuno_serial/serialconlogger.f90 create mode 100644 src/fortuno_serial/serialcontext.f90 create mode 100644 src/fortuno_serial/serialdriver.f90 create mode 100644 src/fortuno_serial/serialglobalctx.f90 create mode 100644 src/fortuno_serial/serialsuite.f90 create mode 100644 test/export/serial/app/testapp.f90 create mode 100644 test/export/serial/app/testapp_fpp.F90 create mode 100644 test/export/serial/app/testapp_fypp.fypp create mode 100644 test/export/serial/fpm.toml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..3508782 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,45 @@ +name: ci + +on: + push: + branches: [main] + pull_request: + branches: [main] + workflow_dispatch: + +env: + INTERFACE: serial + +jobs: + + # + # Test Fortuno in various system configurations + # + fortuno-test: + + runs-on: ubuntu-latest + + steps: + + - name: Check-out code + uses: actions/checkout@v4 + + - name: Setup Intel compiler + uses: rscohn2/setup-oneapi@v0 + with: + components: | + ifx + + - name: Setup Intel environment + run: | + source /opt/intel/oneapi/setvars.sh + printenv >> ${GITHUB_ENV} + echo "FPM_FC=ifx" >> ${GITHUB_ENV} + + - name: Setup build tools + run: | + pip install fpm + + - name: Test fpm export + run: | + fpm run -C test/export/${INTERFACE} testapp diff --git a/fpm.toml b/fpm.toml new file mode 100644 index 0000000..6b22a17 --- /dev/null +++ b/fpm.toml @@ -0,0 +1,11 @@ +name = "fortuno" +version = "0.1.0" +license = "BSD-2-Clause-Patent" +author = "Fortuno authors" +maintainer = "aradi@uni-bremen.de" +copyright = "Copyright 2024, Fortuno authors" + +[fortran] +implicit-typing = false +implicit-external = false +source-form = "free" diff --git a/src/fortuno.f90 b/src/fortuno.f90 new file mode 100644 index 0000000..097684a --- /dev/null +++ b/src/fortuno.f90 @@ -0,0 +1,20 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Interface module for the core library of the Fortuno testing framework +module fortuno + use fortuno_basetypes, only : test_base, test_case_base, test_item, test_list, test_ptr_item,& + & test_suite_base + use fortuno_chartypes, only : char_rep, char_rep_int, named_details, named_item, named_state + use fortuno_consolelogger, only : console_logger + use fortuno_testcontext, only : context_factory, test_context + use fortuno_checkers, only : is_equal + use fortuno_cmdapp, only : cmd_app + use fortuno_testdriver, only : init_test_driver, test_driver, test_runner, test_selection + use fortuno_testinfo, only : check_result, drive_result, failure_info, failure_location,& + & init_drive_result, init_failure_location, test_result, teststatus + use fortuno_utils, only : as_char, nl + implicit none + +end module fortuno diff --git a/src/fortuno/argumentparser.f90 b/src/fortuno/argumentparser.f90 new file mode 100644 index 0000000..99dcaa3 --- /dev/null +++ b/src/fortuno/argumentparser.f90 @@ -0,0 +1,427 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Implements a simple command line argument parser +module fortuno_argumentparser + use fortuno_testlogger, only : test_logger + use fortuno_utils, only : basename, nl, string, string_list + implicit none + + private + public :: argtypes, argument_def, argument_values, argument_parser, init_argument_parser + + ! Helper type for argument types + type :: argument_types_enum_ + integer :: bool = 1 + integer :: int = 2 + integer :: float = 3 + integer :: string = 4 + integer :: stringlist = 5 + end type argument_types_enum_ + + !> Possible argument types + type(argument_types_enum_), parameter :: argtypes = argument_types_enum_() + + + !> Contains a definition of a command line argument + type :: argument_def + + !> Name associated with the argument + character(:), allocatable :: name + + !> Type of the argument (one field of argtypes) + integer :: argtype = -1 + + !> Short option form, use "" for options with long form only and for positional arguments + character :: shortopt = "" + + !> Long option form, leave unallocated for options with short form only and positional arguments + character(:), allocatable :: longopt + + !> Default value to use, if option had not been specified, leave unallocated for no default + class(*), allocatable :: default + + !> Help message to print for the argument + character(:), allocatable :: helpmsg + + end type argument_def + + + !> An argument value obtained after parsing + type :: argument_value + + !> Name associated with the argument + character(:), allocatable :: name + + !> Parsed value of the argument (unallocated for logical arguments) + class(*), allocatable :: argval + + 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 + type(argument_value), allocatable :: argvals(:) + contains + procedure :: has => argument_values_has + procedure :: get_value_stringlist => argument_values_get_value_stringlist + generic :: get_value => get_value_stringlist + end type argument_values + + + !> Argument parser + type :: argument_parser + private + type(argument_def), allocatable :: argdefs(:) + character(:), allocatable :: description + contains + procedure :: parse_args => argument_parser_parse_args + end type argument_parser + + + integer, parameter :: terminal_width_ = 80 + +contains + + !> Initializes an argument parser + subroutine init_argument_parser(this, description, argdefs) + + !> Instance + type(argument_parser), intent(out) :: this + + !> Description to print when help is required + character(*), intent(in) :: description + + !> Argument definitions + type(argument_def), intent(in) :: argdefs(:) + + this%argdefs = argdefs + this%description = description + + end subroutine init_argument_parser + + + !> Parses command command line arguments + subroutine argument_parser_parse_args(this, argumentvalues, logger, exitcode) + + !> Instance + class(argument_parser), intent(inout) :: this + + !> Argument values obtained during parsing + type(argument_values), intent(out) :: argumentvalues + + !> Logger for issuing messages + class(test_logger), intent(inout) :: logger + + !> Exit code (-1, if processing can continue, >= 0 if processing should stop) + integer, intent(out) :: exitcode + + type(string), allocatable :: cmdargs(:), posargs(:) + logical, allocatable :: processed(:) + character(:), allocatable :: argname + integer :: nargs, nargdefs, iarg, iargdef + logical optionsallowed, islong, matches + + exitcode = -1 + + call get_command_line_args_(cmdargs) + nargs = ubound(cmdargs, dim=1) + nargdefs = size(this%argdefs) + allocate(processed(nargdefs), source=.false.) + + allocate(argumentvalues%argvals(0)) + allocate(posargs(0)) + optionsallowed = .true. + + ! Process all arguments + iarg = 0 + argloop: do while (iarg < nargs) + iarg = iarg + 1 + associate (arg => cmdargs(iarg)%content) + if (arg == "--") then + optionsallowed = .false. + cycle + end if + if (.not. optionsallowed .or. arg(1:1) /= "-") then + posargs = [posargs, string(arg)] + cycle + end if + islong = arg(1:min(len(arg), 2)) == "--" + if (islong) then + argname = arg(3:) + else if (len(arg) == 2) then + argname = arg(2:2) + else + call logger%log_error("Invalid short option '" // cmdargs(iarg)%content // "'") + exitcode = 1 + return + end if + if ((islong .and. argname == "help") .or. (.not. islong .and. argname == "h")) then + call print_help_(logger, cmdargs(0)%content, this%description, this%argdefs) + exitcode = 0 + return + end if + do iargdef = 1, nargdefs + associate (argdef => this%argdefs(iargdef)) + matches = .false. + if (islong .and. allocated(argdef%longopt)) then + matches = argdef%longopt == argname + else if (.not. islong .and. argdef%shortopt /= "") then + matches = argdef%shortopt == argname + end if + if (matches) then + select case (argdef%argtype) + case (argtypes%bool) + ! Workaround:gfortran:14.1 (bug 116679) + ! Omit array expression to avoid memory leak + ! {- + ! argumentvalues%argvals = [argumentvalues%argvals, argument_value(argdef%name)] + ! -}{+ + block + type(argument_value), allocatable :: argvalbuffer(:) + integer :: nn + nn = size(argumentvalues%argvals) + allocate(argvalbuffer(nn + 1)) + argvalbuffer(1 : nn) = argumentvalues%argvals + argvalbuffer(nn + 1) = argument_value(argdef%name) + call move_alloc(argvalbuffer, argumentvalues%argvals) + end block + ! +} + + case default + call logger%log_error("Unknown argument type") + exitcode = 1 + return + end select + cycle argloop + end if + end associate + end do + call logger%log_error("invalid option '" // arg // "'") + exitcode = 1 + return + end associate + end do argloop + + ! Check collected positional arguments + 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 + ! Workaround:gfortran:14.1 (bug 116679) + ! Omit array expression to avoid memory leak + ! {- + ! argumentvalues%argvals = [argumentvalues%argvals,& + ! & argument_value(argdef%name, argval=string_list(posargs))] + ! -}{+ + block + type(argument_value), allocatable :: argvalbuffer(:) + integer :: nn + nn = size(argumentvalues%argvals) + allocate(argvalbuffer(nn + 1)) + argvalbuffer(1 : nn) = argumentvalues%argvals + argvalbuffer(nn + 1) = argument_value(argdef%name, argval=string_list(posargs)) + call move_alloc(argvalbuffer, argumentvalues%argvals) + end block + ! +} + + else if (size(posargs) > 1) then + call logger%log_error("Superfluous positional arguments found") + exitcode = 1 + return + end if + end associate + + end subroutine argument_parser_parse_args + + + !> Cheks whether a given name is contained in the argument value collection + function argument_values_has(this, name) result(found) + + !> Instance + class(argument_values), intent(in) :: this + + !> Name to search for + character(*), intent(in) :: name + + !> Whether collection has entry with given name + logical :: found + + integer :: iargval + + found = .false. + do iargval = 1, size(this%argvals) + found = this%argvals(iargval)%name == name + if (found) return + end do + + end function argument_values_has + + + !> Returns the value of a parsed argument as array of strings + subroutine argument_values_get_value_stringlist(this, name, val) + + !> Instance + class(argument_values), intent(in) :: this + + !> Name of the argument + character(*), intent(in) :: name + + !> Value on exit + type(string), allocatable, intent(out) :: val(:) + + logical :: found + integer :: iargval + + found = .false. + do iargval = 1, size(this%argvals) + found = this%argvals(iargval)%name == name + if (found) exit + end do + if (found) then + select type (argval => this%argvals(iargval)%argval) + type is (string_list) + val = argval%items + class default + error stop "Invalid argument type for argument '" // name // "'" + end select + else + error stop "Argument '" // name // "' not found" + end if + + 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(:) + + integer :: nargs, iarg, arglen + + nargs = command_argument_count() + allocate(cmdargs(0:nargs)) + do iarg = 0, nargs + call get_command_argument(iarg, length=arglen) + allocate(character(arglen) :: cmdargs(iarg)%content) + call get_command_argument(iarg, value=cmdargs(iarg)%content) + end do + + end subroutine get_command_line_args_ + + + !! Prints help information. + subroutine print_help_(logger, scriptname, description, argdefs) + class(test_logger), intent(inout) :: logger + character(*), intent(in) :: scriptname, description + type(argument_def), intent(in) :: argdefs(:) + + integer :: iargdef + character(:), allocatable :: line, buffer + + line = "Usage: " // basename(scriptname) // " [-h]" + do iargdef = 1, size(argdefs) + associate(argdef => argdefs(iargdef)) + if (argdef%shortopt /= "") then + line = line // " [-" // argdef%shortopt // "]" + else if (allocated(argdef%longopt)) then + line = line // " [--" // argdef%longopt // "]" + else + line = line // " [" // argdef%name // "]" + end if + end associate + end do + call logger%log_message(line // nl // nl) + call logger%log_message(description) + associate (argdef => argdefs(size(argdefs))) + ! If last argument is a positional argument + if (argdef%shortopt == "" .and. .not. allocated(argdef%longopt)) then + call print_argument_help_(logger, argdef%name, argdef%helpmsg, terminal_width_) + end if + end associate + call logger%log_message(nl // "Options:") + call print_argument_help_(logger, "-h, --help", "show this help message and exit",& + & terminal_width_) + do iargdef = 1, size(argdefs) + associate(argdef => argdefs(iargdef)) + if (argdef%shortopt /= "" .and. allocated(argdef%longopt)) then + buffer = "-" // argdef%shortopt // ", --" // argdef%longopt + else if (argdef%shortopt /= "") then + buffer = "-" // argdef%shortopt + else if (allocated(argdef%longopt)) then + buffer = "--" // argdef%longopt + else + cycle + end if + line = " " // buffer // repeat(" ", max(0, 24 - len(buffer) - 2)) // argdef%helpmsg + call logger%log_message(line) + end associate + end do + + end subroutine print_help_ + + + !! Prints the help for a single argument. + subroutine print_argument_help_(logger, argument, helpmsg, linelength) + class(test_logger), intent(inout) :: logger + character(*), intent(in) :: argument, helpmsg + integer, intent(in) :: linelength + + integer, parameter :: offset = 25 + character(20) :: formatstr + character(linelength) :: buffer + integer :: maxwidth, curpos, seppos + + write(formatstr, "(a, i0, a)") "(2x, a, t", offset, ", a)" + maxwidth = linelength - offset + curpos = 1 + do while (curpos <= len(helpmsg)) + if (curpos + maxwidth - 1 > len(helpmsg)) then + if (curpos == 1) then + write(buffer, formatstr) argument, helpmsg(curpos:) + else + write(buffer, formatstr) "", helpmsg(curpos:) + end if + call logger%log_message(trim(buffer)) + exit + else + seppos = index(helpmsg(curpos : curpos + maxwidth), " ", back=.true.) + curpos - 1 + if (seppos < curpos + maxwidth / 2) seppos = curpos + maxwidth + if (curpos == 1) then + write(buffer, formatstr) argument, helpmsg(curpos : seppos - 1) + else + write(buffer, formatstr) "", helpmsg(curpos : seppos - 1) + end if + call logger%log_message(buffer) + if (helpmsg(seppos:seppos) == " ") then + curpos = seppos + 1 + else + curpos = seppos + end if + end if + end do + + end subroutine print_argument_help_ + +end module fortuno_argumentparser \ No newline at end of file diff --git a/src/fortuno/basetypes.f90 b/src/fortuno/basetypes.f90 new file mode 100644 index 0000000..e05edd2 --- /dev/null +++ b/src/fortuno/basetypes.f90 @@ -0,0 +1,244 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains base classes for itemizable test objects +module fortuno_basetypes + implicit none + + private + public :: test_base, test_case_base, test_suite_base + public :: test_item, test_ptr_item + public :: test_list + + + !> Base class for all test objects + !! + !! Represents a generic test object, which can be a test case or a test suite. + !! + type, abstract :: test_base + + !> Name of the generic test + character(:), allocatable :: name + + end type test_base + + + !> Wrapped test_base class instance for building arrays of generic test object instances + type :: test_item + + !> Actual test_base class instance + class(test_base), pointer :: item => null() + + contains + + procedure :: init => test_item_init + + end type test_item + + !> Structure constructor for test_item + interface test_item + module procedure new_test_item + end interface test_item + + + !> Wrapped test_base class pointer for building arrays of generic test object view pointers + type :: test_ptr_item + + !> Actual test_base class pointer + class(test_base), pointer :: item => null() + + end type test_ptr_item + + + !> A list of test_base instances + type :: test_list + private + type(test_ptr_item), pointer :: storage_(:) => null() + integer :: nitems = 0 + contains + procedure :: size => test_list_size + procedure :: view => test_list_view + procedure :: free => test_list_free + procedure, private :: ensure_storage_size_ => test_list_ensure_storage_size_ + end type + + + !> Structure constructor for test_list + interface test_list + module procedure new_test_list_from_items, new_test_list_from_lists + end interface test_list + + + !> Base class for all test cases + type, extends(test_base), abstract :: test_case_base + end type test_case_base + + + !> Base class for all test suites containing test cases and other test suites + type, extends(test_base), abstract :: test_suite_base + + !> List of tests objects (test_cases and test suites) the suite contains + type(test_list) :: tests + + end type test_suite_base + +contains + + !> Initializes a test item with the copy of a test_base instance. + !! + !! Note: This should be done only once for a test item instance. If the instance has already a + !! content, it will stop with an error. + !! + subroutine test_item_init(this, test) + + !> Instance + class(test_item), intent(inout) :: this + + !> Test to copy and store as test_item + class(test_base), intent(in) :: test + + if (associated(this%item)) error stop "Double initialization of a test_item instance" + allocate(this%item, source=test) + + end subroutine test_item_init + + + !> Returns a test item with the copy a test_base instance. + function new_test_item(test) result(this) + + !> Test to copy and store as test_item + class(test_base), intent(in) :: test + + !> Initialized instance on return + type(test_item) :: this + + call this%init(test) + + end function new_test_item + + + !> Creates a new test_list from an array of test_item instances. + function new_test_list_from_items(testitems) result(this) + + !> Test item instances to store in the test_list + type(test_item), intent(in) :: testitems(:) + + !> Initialized instance on return + type(test_list) :: this + + integer :: ii + + call this%ensure_storage_size_(size(testitems)) + do ii = 1, size(testitems) + this%storage_(ii)%item => testitems(ii)%item + end do + this%nitems = size(testitems) + + end function new_test_list_from_items + + + !> Creates a new test_list from an array of test_lists + function new_test_list_from_lists(testlists) result(this) + + !> Array of test_lists + type(test_list), intent(in) :: testlists(:) + + !> Initialized instance on return + type(test_list) :: this + + integer :: totalsize + integer :: ilist, iitem + + totalsize = sum(testlists%size()) + call this%ensure_storage_size_(totalsize) + do ilist = 1, size(testlists) + associate (list => testlists(ilist)) + do iitem = 1, list%nitems + this%storage_(this%nitems + iitem)%item => list%storage_(iitem)%item + end do + this%nitems = this%nitems + list%nitems + end associate + end do + + end function new_test_list_from_lists + + + !> Returns the size of the list + pure elemental function test_list_size(this) result(listsize) + + !> Instance + class(test_list), intent(in) :: this + + !> Nr. of elements in the list + integer :: listsize + + listsize = this%nitems + + end function test_list_size + + + !> Returns a pointer to a given element of the list + function test_list_view(this, ind) result(itemptr) + + !> Instance + class(test_list), intent(in) :: this + + !> Element to get a view to + integer, intent(in) :: ind + + !> Pointer to the given test_base instance + class(test_base), pointer :: itemptr + + itemptr => this%storage_(ind)%item + + end function test_list_view + + + !> Recursively frees all elements contained in the list + recursive subroutine test_list_free(this) + class(test_list), intent(inout) :: this + + integer :: ii + + if (.not. associated(this%storage_)) return + do ii = 1, this%nitems + select type (item => this%storage_(ii)%item) + class is (test_suite_base) + call item%tests%free() + end select + deallocate(this%storage_(ii)%item) + end do + deallocate(this%storage_) + this%nitems = 0 + + end subroutine test_list_free + + + !! Ensures that the test_list has enough storage for a given size + subroutine test_list_ensure_storage_size_(this, newsize) + class(test_list), intent(inout) :: this + integer, intent(in) :: newsize + + type(test_ptr_item), pointer :: buffer(:) + integer :: storagesize + + if (associated(this%storage_)) then + storagesize = size(this%storage_) + else + storagesize = 0 + end if + if (newsize <= storagesize) return + + if (associated(this%storage_)) then + buffer => this%storage_ + else + buffer => null() + end if + storagesize = max(newsize, storagesize + 10, int(real(storagesize) * 1.3)) + allocate(this%storage_(storagesize)) + if (associated(buffer)) this%storage_(1:this%nitems) = buffer(1:this%nitems) + + end subroutine test_list_ensure_storage_size_ + +end module fortuno_basetypes diff --git a/src/fortuno/chartypes.f90 b/src/fortuno/chartypes.f90 new file mode 100644 index 0000000..fe673bf --- /dev/null +++ b/src/fortuno/chartypes.f90 @@ -0,0 +1,223 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains various types related to character representations. +module fortuno_chartypes + use fortuno_utils, only : as_char, as_upper, nl, string + implicit none + + private + public :: char_rep + public :: char_rep_int + public :: named_item, named_details, named_state + + + !> Character representable object. + type, abstract :: char_rep + contains + procedure(char_rep_as_char), deferred :: as_char + end type char_rep + + + abstract interface + + !> Character representation of the char_rep object. + function char_rep_as_char(this) result(repr) + import :: char_rep + implicit none + + !> Instance + class(char_rep), intent(in) :: this + + !> Character representation of the object. + character(:), allocatable :: repr + + end function char_rep_as_char + + end interface + + + !> Implements a named item of arbitrary type + type :: named_item + + !> Name + character(:), allocatable :: name + + !> Value associated with the name + class(*), allocatable :: value + + end type named_item + + + ! Workaround:gfortran:13.2 + ! Needs user defined structure constructor as default constructor can not deal with class(*) field + interface named_item + module procedure new_named_item + end interface + + + !> Represents failure details with an array of named items. + type, extends(char_rep) :: named_details + + !> Items containing the information about the failure details + type(named_item), allocatable :: items(:) + + contains + procedure :: as_char => named_details_as_char + end type named_details + + + !> Represents test internal state with an array of named items. + type, extends(char_rep) :: named_state + + !> Items containing the information about the failure details + type(named_item), allocatable :: items(:) + + contains + procedure :: as_char => named_state_as_char + end type named_state + + + !> Character representable integer. + type, extends(char_rep) :: char_rep_int + + !> Value + integer :: value + + contains + procedure :: as_char => char_rep_int_as_char + end type char_rep_int + +contains + + + !> Returns the character representation of the failure details. + function named_details_as_char(this) result(repr) + + !> Instance + class(named_details), intent(in) :: this + + !> Character representation + character(:), allocatable :: repr + + if (.not. allocated(this%items)) then + repr = "" + return + end if + call get_named_items_as_char_(this%items, repr, itemsep=nl, namesep=": ",& + & capitalizename=.true.) + + end function named_details_as_char + + + !> Returns the character representation of an internal test state. + function named_state_as_char(this) result(repr) + + !> Instance + class(named_state), intent(in) :: this + + !> Character representation + character(:), allocatable :: repr + + if (.not. allocated(this%items)) then + repr = "" + return + end if + call get_named_items_as_char_(this%items, repr, itemsep=nl, namesep=":",& + & capitalizename=.false.) + + end function named_state_as_char + + + !> Integer with string representation. + function char_rep_int_as_char(this) result(repr) + + !> Instance + class(char_rep_int), intent(in) :: this + + !> Character representation + character(:), allocatable :: repr + + repr = as_char(this%value) + + end function char_rep_int_as_char + + + !> Explicit constructor for named_item (to avoid gfortran compilation problems) + function new_named_item(name, val) result(this) + + !> Name of the item + character(*), intent(in) :: name + + !> Value of the item + class(*), intent(in) :: val + + !> Initialized instance + type(named_item) :: this + + this%name = name + allocate(this%value, source=val) + + end function new_named_item + + + !! Returns the character representation of an array of named items. + subroutine get_named_items_as_char_(items, repr, itemsep, namesep, capitalizename) + type(named_item), intent(in) :: items(:) + character(:), allocatable, intent(out) :: repr + character(*), intent(in) :: itemsep, namesep + logical, intent(in) :: capitalizename + + integer :: nitems, iitem, pos, reprlen, itemseplen, nameseplen + type(string), allocatable :: valuestrings(:) + + nitems = size(items) + if (nitems == 0) then + repr = "" + return + end if + reprlen = 0 + allocate(valuestrings(size(items))) + do iitem = 1, nitems + reprlen = reprlen + len(items(iitem)%name) + select type (namedvalue => items(iitem)%value) + type is (character(*)) + valuestrings(iitem)%content = namedvalue + class is (string) + valuestrings(iitem)%content = namedvalue%content + class is (char_rep) + valuestrings(iitem)%content = namedvalue%as_char() + class default + valuestrings(iitem)%content = "???" + end select + reprlen = reprlen + len(valuestrings(iitem)%content) + end do + + nameseplen = len(namesep) + itemseplen = len(itemsep) + reprlen = reprlen + nitems * nameseplen + (nitems - 1) * itemseplen + allocate(character(reprlen) :: repr) + + pos = 1 + do iitem = 1, nitems + associate(name => items(iitem)%name, valstr => valuestrings(iitem)%content) + reprlen = len(name) + repr(pos : pos + reprlen - 1) = name + if (capitalizename) repr(pos:pos) = as_upper(repr(pos:pos)) + pos = pos + reprlen + repr(pos : pos + nameseplen - 1) = namesep + pos = pos + nameseplen + reprlen = len(valstr) + repr(pos : pos + reprlen - 1) = valstr + pos = pos + reprlen + if (iitem /= nitems) then + repr(pos : pos + itemseplen - 1) = itemsep + pos = pos + itemseplen + end if + end associate + end do + + end subroutine get_named_items_as_char_ + +end module fortuno_chartypes diff --git a/src/fortuno/checkers.f90 b/src/fortuno/checkers.f90 new file mode 100644 index 0000000..c8f763f --- /dev/null +++ b/src/fortuno/checkers.f90 @@ -0,0 +1,62 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains some built-in checkers +module fortuno_checkers + use fortuno_chartypes, only : char_rep_int, named_details, named_item + use fortuno_testinfo, only : check_result + implicit none + + private + public :: is_equal + + + !> Checks whether two entities are equal + interface is_equal + module procedure is_equal_i0_i0 + end interface is_equal + +contains + + + !> Checks whether two integer values are equal + function is_equal_i0_i0(obtained, expected) result(checkresult) + + !> Obtained value + integer, intent(in) :: obtained + + !> Expected value + integer, intent(in) :: expected + + !> Result of the check + type(check_result) :: checkresult + + checkresult%success = (obtained == expected) + if (.not. checkresult%success) then + ! Workaround:gfortran:14.1 (bug 116679) + ! Omit array expression to avoid memory leak + ! {- + ! checkresult%details = named_details([& + ! & named_item("failure", "mismatching integer values"),& + ! & named_item("expected", char_rep_int(expected)),& + ! & named_item("obtained", char_rep_int(obtained))& + ! & ]) + ! -}{+ + block + type(named_details), allocatable :: nameddetails + allocate(nameddetails) + allocate(nameddetails%items(3)) + associate (items => nameddetails%items) + items(1) = named_item("failure", "mismatching integer values") + items(2) = named_item("expected", char_rep_int(expected)) + items(3) = named_item("obtained", char_rep_int(obtained)) + end associate + call move_alloc(nameddetails, checkresult%details) + end block + ! +} + end if + + end function is_equal_i0_i0 + +end module fortuno_checkers \ No newline at end of file diff --git a/src/fortuno/cmdapp.f90 b/src/fortuno/cmdapp.f90 new file mode 100644 index 0000000..b6ca0a1 --- /dev/null +++ b/src/fortuno/cmdapp.f90 @@ -0,0 +1,190 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains common code used by the various command line apps +module fortuno_cmdapp + use fortuno_argumentparser, only : argtypes, argument_def, argument_values, argument_parser,& + & init_argument_parser + use fortuno_basetypes, only : test_list + use fortuno_utils, only : string + use fortuno_testdriver, only : test_driver, test_selection + use fortuno_testlogger, only : test_logger + implicit none + + private + public :: cmd_app + public :: get_selections + public :: default_argument_defs + + + !> App for driving tests through command line interface app + type :: cmd_app + class(test_logger), allocatable :: logger + class(test_driver), allocatable :: driver + type(argument_values) :: argvals + contains + procedure :: run => cmd_app_run + procedure :: parse_args => cmd_app_parse_args + procedure :: register_tests => cmd_app_register_tests + procedure :: run_tests => cmd_app_run_tests + end type cmd_app + + +contains + + !> Runs the command line interface app (calls parse_args(), register_tests() and run_tests()) + subroutine cmd_app_run(this, tests, exitcode) + + !> Instance + class(cmd_app), intent(inout) :: this + + !> Test items to be considered by the app + type(test_list), intent(in) :: tests + + !> Exit code of the run + integer, intent(out) :: exitcode + + call this%parse_args(exitcode) + if (exitcode >= 0) return + call this%register_tests(tests, exitcode) + if (exitcode >= 0) return + call this%run_tests(exitcode) + + end subroutine cmd_app_run + + + !> Parses the command line arguments + subroutine cmd_app_parse_args(this, exitcode) + + !> Instance + class(cmd_app), intent(inout) :: this + + !> Exit code (-1 if processing can continue, >=0 if program should stop with that exit code) + integer, intent(out) :: exitcode + + type(argument_parser) :: argparser + + call init_argument_parser(argparser,& + & description="Command line app for driving Fortuno unit tests.",& + & argdefs=default_argument_defs()& + & ) + call argparser%parse_args(this%argvals, this%logger, exitcode) + + end subroutine cmd_app_parse_args + + + !> Register all tests which should be considered + subroutine cmd_app_register_tests(this, testitems, exitcode) + + !> Initialized instance on exit + class(cmd_app), intent(inout) :: this + + !> Items to be considered by the app + type(test_list), intent(in) :: testitems + + !> Exit code (-1, if processing can continue, >= 0 otherwise) + integer, intent(out) :: exitcode + + type(test_selection), allocatable :: selections(:) + type(string), allocatable :: selectors(:), testnames(:) + integer :: itest + + exitcode = -1 + if (this%argvals%has("tests")) then + call this%argvals%get_value("tests", selectors) + call get_selections(selectors, selections) + end if + call this%driver%register_tests(testitems, selections=selections) + + if (this%argvals%has("list")) then + call this%driver%get_test_names(testnames) + do itest = 1, size(testnames) + call this%logger%log_message(testnames(itest)%content) + end do + exitcode = 0 + return + end if + + end subroutine cmd_app_register_tests + + + !> Runs the initialized app + subroutine cmd_app_run_tests(this, exitcode) + + !> Instance + class(cmd_app), intent(inout) :: this + + !> Exit code of the test run (0 - success, 1 - failure) + integer, intent(out) :: exitcode + + call this%driver%run_tests(this%logger) + if (this%driver%driveresult%successful) then + exitcode = 0 + else + exitcode = 1 + end if + + end subroutine cmd_app_run_tests + + + !> Converts test selector expressions to test selections + subroutine get_selections(selectors, selections) + + !> Selector expressions + type(string), intent(in) :: selectors(:) + + !> Array of selections on exit + type(test_selection), allocatable, intent(out) :: selections(:) + + integer :: ii + + allocate(selections(size(selectors))) + do ii = 1, size(selectors) + associate(selector => selectors(ii)%content, selection => selections(ii)) + if (selector(1:1) == "~") then + selection%name = selector(2:) + selection%selectiontype = "-" + else + selection%name = selector + selection%selectiontype = "+" + end if + end associate + end do + + end subroutine get_selections + + + !> Returns the default argument definitions for the command line apps + function default_argument_defs() result(argdefs) + + !> Argument defintions + type(argument_def), allocatable :: argdefs(:) + + ! Workaround:gfortran:14.1 (bug 116679) + ! Omit array expression to avoid memory leak + ! {- + ! argdefs = [& + ! & & + ! & argument_def("list", argtypes%bool, shortopt="l", longopt="list",& + ! & helpmsg="show list of tests to run and exit"),& + ! & & + ! & argument_def("tests", argtypes%stringlist,& + ! & helpmsg="list of tests and suites to include or to exclude when prefixed with '~' (e.g.& + ! & 'somesuite ~somesuite/avoidedtest' would run all tests except 'avoidedtest' in the test& + ! & suite 'somesuite')")& + ! & & + ! & ] + ! -}{+ + allocate(argdefs(2)) + argdefs(1) = argument_def("list", argtypes%bool, shortopt="l", longopt="list",& + & helpmsg="show list of tests to run and exit") + argdefs(2) = argument_def("tests", argtypes%stringlist,& + & helpmsg="list of tests and suites to include or to exclude when prefixed with '~' (e.g.& + & 'somesuite ~somesuite/avoidedtest' would run all tests except 'avoidedtest' in the test& + & suite 'somesuite')") + ! +} + + end function default_argument_defs + +end module fortuno_cmdapp diff --git a/src/fortuno/consolelogger.f90 b/src/fortuno/consolelogger.f90 new file mode 100644 index 0000000..6d6e63e --- /dev/null +++ b/src/fortuno/consolelogger.f90 @@ -0,0 +1,421 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains the implementation of the test logger for logging on the console +module fortuno_consolelogger + use fortuno_testinfo, only : drive_result, failure_info, test_result, teststatus + use fortuno_testlogger, only : test_logger + use fortuno_utils, only : ansicolors, as_char, stderr, stdout + implicit none + + private + public :: console_logger + + + !> Implements a logger which logs to the console + type, extends(test_logger) :: console_logger + contains + procedure :: is_active => console_logger_is_active + procedure :: get_failure_info_repr => console_logger_get_failure_info_repr + procedure :: log_message => console_logger_log_message + procedure :: log_error => console_logger_log_error + procedure :: start_drive => console_logger_start_drive + procedure :: end_drive => console_logger_end_drive + procedure :: start_tests => console_logger_start_tests + procedure :: end_tests => console_logger_end_tests + procedure :: log_test_result => console_logger_log_test_result + procedure :: log_drive_result => console_logger_log_drive_result + end type console_logger + + + character(*), parameter :: notrun_short_ = "!" + character(*), parameter :: succeeded_short_ = "." + character(*), parameter :: failed_short_ = "F" + character(*), parameter :: skipped_short_ = "s" + character(*), parameter :: ignored_short_ = "I" + character(*), parameter :: unknown_short_ = "?" + + character(*), parameter :: notrun_long_ =& + & ansicolors%red // "Not run " // ansicolors%default + + character(*), parameter :: succeeded_long_ =& + & ansicolors%default // "OK " // ansicolors%default + + character(*), parameter :: failed_long_ = & + & ansicolors%red // "Failed " // ansicolors%default + + character(*), parameter :: skipped_long_ =& + & ansicolors%cyan // "Skipped " // ansicolors%default + + character(*), parameter :: ignored_long_ =& + & ansicolors%magenta // "Ignored " // ansicolors%default + + character(*), parameter :: unknown_long_ =& + & ansicolors%yellow // "??????? " // ansicolors%default + +contains + + + !> Returns whether the logger is active + function console_logger_is_active(this) result(isactive) + + !> Instance + class(console_logger), intent(in) :: this + + !> Whether logger is active + logical :: isactive + + isactive = .true. + + end function console_logger_is_active + + + !> Returns the representation of the failure information (called collectively) + subroutine console_logger_get_failure_info_repr(this, failureinfo, location, message,& + & details) + + !> Instance + class(console_logger), intent(in) :: this + + !> Failure info to get the representation from + type(failure_info), allocatable, intent(in) :: failureinfo + + !> Location string (unallocated if not available or not relevant) + character(:), allocatable, intent(out) :: location + + !> Message string (unallocated if not available or not relevant) + character(:), allocatable, intent(out) :: message + + !> Details string (unallocated if not available or not relevant) + character(:), allocatable, intent(out) :: details + + location = failureinfo%location%as_char() + if (allocated(failureinfo%message)) message = failureinfo%message + if (allocated(failureinfo%details)) details = failureinfo%details%as_char() + + end subroutine console_logger_get_failure_info_repr + + + !> Logs a normal message + subroutine console_logger_log_message(this, message) + + !> Instance + class(console_logger), intent(inout) :: this + + !> Message to log + character(*), intent(in) :: message + + if (.not. this%is_active()) return + write(stdout, "(a)") message + + end subroutine console_logger_log_message + + + !> Logs an error message + subroutine console_logger_log_error(this, message) + + !> Instance + class(console_logger), intent(inout) :: this + + !> Message to log + character(*), intent(in) :: message + + if (.not. this%is_active()) return + write(stderr, "(a)") message + + end subroutine console_logger_log_error + + + !> Starts the logging, called before any other procedures are called + subroutine console_logger_start_drive(this) + + !> Instance + class(console_logger), intent(inout) :: this + + if (.not. this%is_active()) return + write(stdout, "(a)") "=== Fortuno - flextensible unit testing framework for Fortran ===" + + end subroutine console_logger_start_drive + + + !> Ends the logging, called when no more logging is needed + subroutine console_logger_end_drive(this) + + !> Instance + class(console_logger), intent(inout) :: this + + end subroutine console_logger_end_drive + + + !> Starts the processing log, called immediately before the processing of the tests starts + subroutine console_logger_start_tests(this) + + !> Instance + class(console_logger), intent(inout) :: this + + if (.not. this%is_active()) return + write(stdout, "(/, a)") "# Executing test items" + + end subroutine console_logger_start_tests + + + !> Ends processing log, called after the processing of all tests had been finished + subroutine console_logger_end_tests(this) + + !> Instance + class(console_logger), intent(inout) :: this + + if (.not. this%is_active()) return + write(stdout, "()") + + end subroutine console_logger_end_tests + + + !> Logs the result of an individual test during processing + subroutine console_logger_log_test_result(this, testtype, testresult) + + !> Instance + class(console_logger), intent(inout) :: this + + !> Type of the test to be logged (suitesetup, suiteteardown, testrun) + integer, intent(in) :: testtype + + !> Result of the test to log + type(test_result), intent(in) :: testresult + + if (.not. this%is_active()) return + write(stdout, "(a)", advance="no") status_short_repr_(testresult%status) + + end subroutine console_logger_log_test_result + + + !> Logs the final detailed summary after all tests had been run + subroutine console_logger_log_drive_result(this, driveresult) + + !> Instance + class(console_logger), intent(inout) :: this + + !> Results of suite initializers and finalizers (shape: (2, ntestsuites)) + type(drive_result), intent(in) :: driveresult + + integer :: numfieldwidth, maxitems + + ! event logging might need collective communication of all loggers + call log_events_(this, driveresult%suiteresults, driveresult%testresults) + if (.not. this%is_active()) return + + maxitems = maxval([sum(driveresult%suitestats, dim=1), sum(driveresult%teststats)]) + numfieldwidth = len(as_char(maxitems)) + call log_summary_("# Suite set-ups", driveresult%suiteresults(1, :),& + & driveresult%suitestats(:, 1), numfieldwidth) + call log_summary_("# Suite tear-downs", driveresult%suiteresults(2, :),& + & driveresult%suitestats(:, 2), numfieldwidth) + call log_summary_("# Test runs", driveresult%testresults, driveresult%teststats,& + & numfieldwidth) + call log_success_(driveresult%successful) + + end subroutine console_logger_log_drive_result + + + !! Returns a single character representation of the test status. + pure function status_short_repr_(status) result(repr) + integer, intent(in) :: status + character(:), allocatable :: repr + + select case (status) + case (teststatus%notrun) + repr = notrun_short_ + case (teststatus%succeeded) + repr = succeeded_short_ + case (teststatus%failed) + repr = failed_short_ + case (teststatus%skipped) + repr = skipped_short_ + case (teststatus%ignored) + repr = ignored_short_ + case default + repr = unknown_short_ + end select + + end function status_short_repr_ + + + !! Returns a single character representation of the test status. + pure function status_long_repr_(status) result(repr) + integer, intent(in) :: status + character(:), allocatable :: repr + + select case (status) + case (teststatus%notrun) + repr = notrun_long_ + case (teststatus%succeeded) + repr = succeeded_long_ + case (teststatus%failed) + repr = failed_long_ + case (teststatus%skipped) + repr = skipped_long_ + case (teststatus%ignored) + repr = ignored_long_ + case default + repr = unknown_long_ + end select + + end function status_long_repr_ + + + !! Logs failure events. + subroutine log_events_(this, suiteresults, testresults) + + !> Instance + class(console_logger), intent(inout) :: this + + !> Results of suite initializers and finalizers (shape: (2, ntestsuites)) + type(test_result), intent(in) :: suiteresults(:,:) + + !> Results of test runs (shape: (ntestcases)) + type(test_result), intent(in) :: testresults(:) + + integer :: ii + + if (any(suiteresults(1, :)%status /= teststatus%succeeded)& + & .or. any(testresults(:)%status /= teststatus%succeeded)& + & .or. any(suiteresults(2, :)%status /= teststatus%succeeded)) then + if (this%is_active()) write(stdout, "(/, a)") "# Logged event(s)" + end if + + if (any(suiteresults(1, :)%status /= teststatus%succeeded)) then + do ii = 1, size(suiteresults, dim=2) + associate (res => suiteresults(1, ii)) + if (res%status == teststatus%succeeded) cycle + if (this%is_active()) then + if (res%status == teststatus%failed) write(stdout, "()") + write(stdout, "(a, 2x, 2a)") status_long_repr_(res%status), "[set-up] ", res%reprname + end if + if (res%status == teststatus%failed) then + ! write_failure_info() needs collective communication, must be called by all loggers + call write_failure_info_(this, res%failureinfo) + if (this%is_active()) write(stdout, "()") + end if + end associate + end do + end if + + if (any(testresults(:)%status /= teststatus%succeeded)) then + do ii = 1, size(testresults) + associate (res => testresults(ii)) + if (res%status == teststatus%succeeded) cycle + if (this%is_active()) then + if (res%status == teststatus%failed) write(stdout, "()") + write(stdout, "(a, 2x, 2a)") status_long_repr_(res%status), "[run] ", res%reprname + end if + if (res%status == teststatus%failed) then + ! write_failure_info() needs collective communication, must be called by all loggers + call write_failure_info_(this, res%failureinfo) + if (this%is_active()) write(stdout, "()") + end if + end associate + end do + end if + + if (any(suiteresults(2, :)%status /= teststatus%succeeded)) then + do ii = 1, size(suiteresults, dim=2) + associate (res => suiteresults(2, ii)) + if (res%status == teststatus%succeeded) cycle + if (this%is_active()) then + if (res%status == teststatus%failed) write(stdout, "()") + write(stdout, "(a, 2x, 2a)") status_long_repr_(res%status), "[tear-down] ", res%reprname + end if + if (res%status == teststatus%failed) then + ! write_failure_info() needs collective communication, must be called by all loggers + call write_failure_info_(this, res%failureinfo) + if (this%is_active()) write(stdout, "()") + end if + end associate + end do + end if + + end subroutine log_events_ + + + !! Writes a failure info. + recursive subroutine write_failure_info_(this, failureinfo) + class(console_logger), intent(in) :: this + type(failure_info), allocatable, intent(in) :: failureinfo + + character(:), allocatable :: location, message, details + + if (.not. allocated(failureinfo)) return + call write_failure_info_(this, failureinfo%previous) + if (failureinfo%location%checknr /= 0) then + if (this%is_active()) & + & write(stdout, "(/, a)") "-> Unsuccessful check" + else + if (this%is_active()) & + & write(stdout, "(/, a)") "-> Failure" + end if + call this%get_failure_info_repr(failureinfo, location, message, details) + if (this%is_active()) then + if (allocated(location)) write(stdout, "(a)") location + if (allocated(message)) write(stdout, "(2a)") "Msg: ", message + if (allocated(details)) write(stdout, "(a, /, a)") "::", details + end if + + end subroutine write_failure_info_ + + + !! Logs test summary + subroutine log_summary_(header, testresults, teststats, numfieldwidth) + character(*), intent(in) :: header + type(test_result), intent(in) :: testresults(:) + integer, intent(in) :: teststats(:) + integer, intent(in) :: numfieldwidth + + integer :: ntotal, ntotal2, nnotrun, nsucceeded, nfailed, nskipped, nignored + character(:), allocatable :: formatstr1, formatstr2, numfieldwidthstr + + ntotal = sum(teststats) + if (ntotal == 0) return + nnotrun = teststats(teststatus%notrun) + nsucceeded = teststats(teststatus%succeeded) + nfailed = teststats(teststatus%failed) + nskipped = teststats(teststatus%skipped) + nignored = teststats(teststatus%ignored) + ntotal2 = ntotal - nskipped + + numfieldwidthstr = as_char(numfieldwidth) + formatstr1 = "(a, 2x, i" // numfieldwidthstr // ")" + formatstr2 = "(a, 2x, i" // numfieldwidthstr // ", 1x, a, f5.1, a)" + + write(stdout, "(/, a)") header + write(stdout, formatstr1) "Total: ", ntotal + if (nskipped > 0) then + write(stdout, formatstr2) "Skipped: ", nskipped, " (", 100.0 * real(nskipped) / ntotal, "%)" + end if + write(stdout, formatstr2) "Succeeded:", nsucceeded, " (", 100.0 * real(nsucceeded) / ntotal,& + & "%)" + if (nfailed > 0) then + write(stdout, formatstr2) "Failed: ", nfailed, " (", 100.0 * real(nfailed) / ntotal, "%)" + end if + if (nignored > 0) then + write(stdout, formatstr2) "Ignored: ", nignored, " (", 100.0 * real(nignored) / ntotal, "%)" + end if + + end subroutine log_summary_ + + + !! Log the success status of the test process + subroutine log_success_(successful) + logical, intent(in) :: successful + + write(stdout, "(/, a)", advance="no") "=== " + if (successful) then + write(stdout, "(4a)", advance="no") ansicolors%green, "Succeeded", ansicolors%default + else + write(stdout, "(4a)", advance="no") ansicolors%red, "FAILED", ansicolors%default + end if + write(stdout, "(a)") " ===" + + end subroutine log_success_ + +end module fortuno_consolelogger \ No newline at end of file diff --git a/src/fortuno/testcontext.f90 b/src/fortuno/testcontext.f90 new file mode 100644 index 0000000..c3524a3 --- /dev/null +++ b/src/fortuno/testcontext.f90 @@ -0,0 +1,348 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains the base context definition +module fortuno_testcontext + use fortuno_basetypes, only : test_base, test_ptr_item + use fortuno_chartypes, only : char_rep + use fortuno_testinfo, only : check_result, failure_info, failure_location, init_failure_location,& + & teststatus + implicit none + + private + public :: context_factory, test_context + + + !> Base of all test contexts, to be extended by driver specific ones (e.g. serial, mpi, etc.) + type :: test_context + private + + !> Nr. of checks executed so far (needed for enumerating checks if file/line info not available) + integer, public :: nchecks = 0 + + !> Info about check failures in current context + type(failure_info), allocatable :: failureinfo_ + + !> Info about the internal state of the test + class(char_rep), allocatable :: state_ + + !> Status of the context + integer :: status_ = teststatus%succeeded + + ! whether last check failed + logical :: checkfailed_ = .false. + + ! nr. of suite pointers stored so far + integer :: nscopes_ = 0 + + ! buffer for storing the scopes which contain the current item + type(test_ptr_item), allocatable :: scopebuffer_(:) + + contains + procedure :: check_logical => test_context_check_logical + procedure :: check_check_result => test_context_check_check_result + generic :: check => check_logical, check_check_result + procedure :: register_check => test_context_register_check + procedure :: check_failed => test_context_check_failed + procedure :: failed => test_context_failed + procedure :: skip => test_context_skip + procedure :: status => test_context_status + procedure :: pop_failure_info => test_context_pop_failure_info + procedure :: push_scope_ptr => test_context_push_scope_ptr + procedure :: scope_pointers => test_context_scope_pointers + procedure :: create_failure_location => test_context_create_failure_location + procedure :: store_state => test_context_store_state + procedure :: pop_state => test_context_pop_state + end type test_context + + + !> Factory to produce a test context class instance + type, abstract :: context_factory + contains + procedure(context_factory_create_context), deferred :: create_context + end type context_factory + + + abstract interface + + subroutine context_factory_create_context(this, ctx) + import :: context_factory, test_context + implicit none + + !> Instance + class(context_factory), intent(inout) :: this + + !> Test context class instance on exit + class(test_context), allocatable, intent(out) :: ctx + + end subroutine context_factory_create_context + + end interface + +contains + + !> Executes a check (using logical value as check result) + subroutine test_context_check_logical(this, cond, msg, file, line) + + !> Instance + class(test_context), intent(inout) :: this + + !> Whether check condition is fulfilled (check is successful) + logical, intent(in) :: cond + + !> Check message + character(*), optional, intent(in) :: msg + + !> Source file name + character(*), optional, intent(in) :: file + + !> Line information + integer, optional, intent(in) :: line + + call this%register_check(.not. cond, msg=msg, file=file, line=line) + + end subroutine test_context_check_logical + + + !> Registers a check in the context, should be called from check() with the result of the check + subroutine test_context_register_check(this, checkfailed, msg, file, line) + + !> Instance + class(test_context), intent(inout) :: this + + !> Whether check has failed + logical, intent(in) :: checkfailed + + !> Check message + character(*), optional, intent(in) :: msg + + !> Source file name + character(*), optional, intent(in) :: file + + !> Line information + integer, optional, intent(in) :: line + + type(failure_info), allocatable :: failureinfo + + this%nchecks = this%nchecks + 1 + this%checkfailed_ = checkfailed + + ! Not recording failure if check was successful or test is in status 'skipped' + if (.not. this%checkfailed_ .or. this%status_ == teststatus%skipped) return + + this%status_ = teststatus%failed + allocate(failureinfo) + call this%create_failure_location(failureinfo%location, file, line) + if (present(msg)) failureinfo%message = msg + ! Workaround:ifx:2024.0 + ! ifx crashes during compilation with optimization on the move_alloc statement. + ! if (allocated(this%failureinfo_)) call move_alloc(this%failureinfo_, failureinfo%previous) + if (allocated(this%failureinfo_)) call my_move_alloc(this%failureinfo_, failureinfo%previous) + call move_alloc(failureinfo, this%failureinfo_) + + contains + + ! Workaround move_alloc function. + subroutine my_move_alloc(src, trg) + type(failure_info), allocatable, intent(inout) :: src + type(failure_info), allocatable, intent(out) :: trg + + call move_alloc(src, trg) + + end subroutine my_move_alloc + + end subroutine test_context_register_check + + + !> Exectutes a check (using detailed check result information) + subroutine test_context_check_check_result(this, checkresult, msg, file, line) + + !> Instance + class(test_context), intent(inout) :: this + + !> Whether check condition is fulfilled (check is successful) + type(check_result), intent(in) :: checkresult + + !> Check message + character(*), optional, intent(in) :: msg + + !> Source file name + character(*), optional, intent(in) :: file + + !> Line information + integer, optional, intent(in) :: line + + call this%check_logical(checkresult%success, msg, file, line) + ! Test might already have the status 'skipped', do not record failure in that case. + if (.not. (this%check_failed() .and. this%failed())) return + if (allocated(checkresult%details)) this%failureinfo_%details = checkresult%details + + end subroutine test_context_check_check_result + + + !> Whether test has failed already (at some previous check) + pure function test_context_failed(this) result(failed) + + !> Instance + class(test_context), intent(in) :: this + + !> Whether test has failed already + logical :: failed + + failed = (this%status_ == teststatus%failed) + + end function test_context_failed + + + !> Whether the last check has failed + pure function test_context_check_failed(this) result(failed) + + !> Instance + class(test_context), intent(in) :: this + + !> Whether last check has failed + logical :: failed + + failed = this%checkfailed_ + + end function test_context_check_failed + + + !> Current test status + pure function test_context_status(this) result(status) + + !> Instance + class(test_context), intent(in) :: this + + !> Test status + integer :: status + + status = this%status_ + + end function test_context_status + + + !> Sets the test status to skipped (provided no failure occured so far) + subroutine test_context_skip(this) + + !> Instance + class(test_context), intent(inout) :: this + + if (this%status_ == teststatus%succeeded) this%status_ = teststatus%skipped + + end subroutine test_context_skip + + + !> Pops the failure info from the context + subroutine test_context_pop_failure_info(this, failureinfo) + + !> Instance + class(test_context), intent(inout) :: this + + !> Extracted failure info (or unallocated, if no failure info was present) + type(failure_info), allocatable, intent(out) :: failureinfo + + if (allocated(this%failureinfo_)) call move_alloc(this%failureinfo_, failureinfo) + + end subroutine test_context_pop_failure_info + + + !> Pushes a suite pointer to the context + subroutine test_context_push_scope_ptr(this, scopeptr) + + !> Instance + class(test_context), intent(inout) :: this + + !> Pointer to the suite to be pushed + class(test_base), pointer, intent(in) :: scopeptr + + type(test_ptr_item), allocatable :: tmp(:) + + if (this%nscopes_ == 0) then + allocate(this%scopebuffer_(10)) + this%scopebuffer_(1)%item => scopeptr + this%nscopes_ = 1 + return + end if + if (this%nscopes_ == size(this%scopebuffer_)) then + allocate(tmp(int(this%nscopes_ * 1.4))) + tmp(1:this%nscopes_) = this%scopebuffer_(1:this%nscopes_) + call move_alloc(tmp, this%scopebuffer_) + end if + this%nscopes_ = this%nscopes_ + 1 + this%scopebuffer_(this%nscopes_)%item => scopeptr + + end subroutine test_context_push_scope_ptr + + + !> Returns the suite pointers stored in the context + function test_context_scope_pointers(this) result(scopeptrs) + + !> Instance + class(test_context), intent(in) :: this + + !> Pointers to the suites enclosing the current item + type(test_ptr_item), allocatable :: scopeptrs(:) + + if (this%nscopes_ == 0) then + allocate(scopeptrs(0)) + else + scopeptrs = this%scopebuffer_(this%nscopes_ : 1 : -1) + end if + + end function test_context_scope_pointers + + + !> Creates the location of the failure using the appropriate failure_location type + subroutine test_context_create_failure_location(this, failureloc, file, line) + + !> Instance + class(test_context), intent(inout) :: this + + !> Allocated and populated failure location on exit + class(failure_location), allocatable, intent(out) :: failureloc + + !> File where failure occured + character(*), optional, intent(in) :: file + + !> Line where failure occured + integer, optional, intent(in) :: line + + allocate(failure_location :: failureloc) + select type (failureloc) + type is (failure_location) + call init_failure_location(failureloc, this%nchecks, file=file, line=line) + end select + + end subroutine test_context_create_failure_location + + + !> Stores the internal state of the test for better identification/introspection + subroutine test_context_store_state(this, state) + + !> Instane + class(test_context), intent(inout) :: this + + !> Arbitrary (character representable) state object + class(char_rep), intent(in) :: state + + this%state_ = state + + end subroutine test_context_store_state + + + !> Pops the test state from the context + subroutine test_context_pop_state(this, state) + + !> Instance + class(test_context), intent(inout) :: this + + !> Popped state object + class(char_rep), allocatable, intent(out) :: state + + if (allocated(this%state_)) call move_alloc(this%state_, state) + + end subroutine test_context_pop_state + +end module fortuno_testcontext diff --git a/src/fortuno/testdriver.f90 b/src/fortuno/testdriver.f90 new file mode 100644 index 0000000..35c794c --- /dev/null +++ b/src/fortuno/testdriver.f90 @@ -0,0 +1,643 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Implements a generic test driver +module fortuno_testdriver + use fortuno_basetypes, only : test_base, test_case_base, test_list, test_suite_base + use fortuno_chartypes, only : char_rep + use fortuno_testcontext, only : context_factory, test_context + use fortuno_testinfo, only : drive_result, init_drive_result, test_result, teststatus + use fortuno_testlogger, only : test_logger, testtypes + use fortuno_utils, only : basename, string + implicit none + + private + public :: init_test_driver, test_driver + public :: test_runner + public :: test_selection + + + !> Implements the actual calls to the suite setups/teardowns and the test runs + type, abstract :: test_runner + contains + procedure(test_runner_set_up_suite), deferred :: set_up_suite + procedure(test_runner_tear_down_suite), deferred :: tear_down_suite + procedure(test_runner_run_test), deferred :: run_test + end type test_runner + + + abstract interface + + !> Invokes the set-up method of a test suite + subroutine test_runner_set_up_suite(this, testsuite, ctx) + import :: test_context, test_runner, test_suite_base + implicit none + + !> Instance + class(test_runner), intent(in) :: this + + !> Test suite to set up + class(test_suite_base), pointer, intent(in) :: testsuite + + !> Test context to use for the set-up + class(test_context), pointer, intent(in) :: ctx + + end subroutine test_runner_set_up_suite + + + !> Invokes the tear-down method of a test suite + subroutine test_runner_tear_down_suite(this, testsuite, ctx) + import :: test_context, test_runner, test_suite_base + implicit none + + !> Instance + class(test_runner), intent(in) :: this + + !> Test suite to tear down + class(test_suite_base), pointer, intent(in) :: testsuite + + !> Test contect to use for the tear-down + class(test_context), pointer, intent(in) :: ctx + + end subroutine test_runner_tear_down_suite + + + !> Invokes the run method of a test case + subroutine test_runner_run_test(this, test, ctx) + import :: test_case_base, test_context, test_runner + implicit none + + !> Instance + class(test_runner), intent(in) :: this + + !> Test case to run + class(test_case_base), pointer, intent(in) :: test + + !> Test context to use for the run + class(test_context), pointer, intent(in) :: ctx + + end subroutine test_runner_run_test + + end interface + + + !! 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 + integer, allocatable :: identifier(:) + + ! Fully qualified name of the test object + character(:), allocatable :: name + + ! Test suite containing the current item (position in suitedatacont / suiteresults) + integer, allocatable :: dependencies(:) + + end type test_data + + + !! Wrapper type around test data (for efficiency and to circumvent GFortran compiler bugs) + type :: test_data_ptr + type(test_data), pointer :: ptr => null() + contains + final :: final_test_data_ptr + end type test_data_ptr + + + !! Minimalistic automatically growing array of test_data items. + type :: test_data_container + + !! nr. of stored items + integer :: nitems = 0 + + !! the actual items, containing valid entries only for 1:nitems + type(test_data_ptr), allocatable :: items(:) + + contains + procedure :: add => test_data_container_add + 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(test_list) :: testlist + type(test_data_container) :: suitedatacont, testdatacont + type(reversible_mapping) :: suiteselection, testselection + contains + procedure :: register_tests => test_driver_register_tests + procedure :: run_tests => test_driver_run_tests + procedure :: get_test_names => test_driver_get_test_names + final :: final_test_driver + end type test_driver + + + !> Represents a test selection + type :: test_selection + + !> Name of the test to be selected + character(:), allocatable :: name + + !> Type of the selection ("+": inclusion, "-": exclusion) + character :: selectiontype = "+" + + end type + +contains + + + !> Initializes a test driver instance + subroutine init_test_driver(this, ctxfactory, runner) + + !> Instance + type(test_driver), intent(out) :: this + + !> Context factory to use for creating contextes + class(context_factory), intent(in) :: ctxfactory + + !> Test runner for invoking test suite and test case methods + class(test_runner), intent(in) :: runner + + this%ctxfactory = ctxfactory + this%runner = runner + + end subroutine init_test_driver + + + !> Finalizes the test driver (by freeing the allocated pointers in the test list) + subroutine final_test_driver(this) + type(test_driver), intent(inout) :: this + + call this%testlist%free() + + end subroutine final_test_driver + + + !> Registers tests to consider + subroutine test_driver_register_tests(this, testlist, selections) + + !> Instance + class(test_driver), intent(inout) :: this + + !> Items to be considered by the app + type(test_list), intent(in) :: testlist + + !> Selection rule to constrain the testing only to a subset of the test items + type(test_selection), optional, intent(in) :: selections(:) + + this%testlist = testlist + call init_test_data_container(this%suitedatacont, 100) + call init_test_data_container(this%testdatacont, 5000) + call build_test_data_(this%testlist, "", [integer ::], [integer ::], this%testdatacont,& + & this%suitedatacont) + call get_selected_suites_and_tests_(this%suitedatacont, this%testdatacont, this%suiteselection,& + & this%testselection, selections) + + end subroutine test_driver_register_tests + + + !> Runs the initialized app + subroutine test_driver_run_tests(this, logger) + + !> Instance + class(test_driver), intent(inout) :: this + + !> Logger for reporting events + class(test_logger), intent(inout) :: logger + + call init_drive_result(this%driveresult, size(this%suiteselection%fwd),& + & size(this%testselection%fwd)) + + call logger%start_drive() + call logger%start_tests() + call run_suite_initializers_finalizers_(.true., this%testlist, this%suitedatacont,& + & this%suiteselection, this%driveresult%suiteresults, this%ctxfactory, this%runner, logger) + call run_tests_(this%testlist, this%suiteselection, this%driveresult%suiteresults(1, :),& + & this%testdatacont, this%testselection, this%driveresult%testresults,& + & this%ctxfactory, this%runner, logger) + call run_suite_initializers_finalizers_(.false., this%testlist, this%suitedatacont,& + 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) + call logger%end_drive() + + end subroutine test_driver_run_tests + + + !> Returns the names of the registered tests + subroutine test_driver_get_test_names(this, testnames) + + !> Instance + class(test_driver), intent(in) :: this + + !> Name of all tests + type(string), allocatable :: testnames(:) + + integer :: nselect, iselect + + nselect = size(this%testselection%fwd) + allocate(testnames(nselect)) + do iselect = 1, nselect + testnames(iselect)%content = this%testdatacont%items(this%testselection%fwd(iselect))%ptr%name + end do + + end subroutine test_driver_get_test_names + + + !! Runs the initializer or finalizer of each test suite + subroutine run_suite_initializers_finalizers_(initializer, testlist, suitedatacont,& + & suiteselection, suiteresults, ctxfactory, runner, logger) + logical, intent(in) :: initializer + type(test_list), intent(inout) :: testlist + type(test_data_container), intent(inout) :: suitedatacont + 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 + + class(test_context), allocatable :: ctx + character(:), allocatable :: repr + integer :: iselect, idata, depstatus, iresult + + if (initializer) then + iresult = 1 + else + iresult = 2 + end if + + do iselect = 1, size(suiteselection%fwd) + idata = suiteselection%fwd(iselect) + associate (suitedata => suitedatacont%items(idata)%ptr, 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_(testlist, 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_ + + + !! Runs all tests + subroutine run_tests_(testlist, suiteselection, suiteinitresults, testdatacont, testselection,& + & testresults, ctxfactory, runner, logger) + type(test_list), intent(inout) :: testlist + type(reversible_mapping), intent(in) :: suiteselection + type(test_result), intent(in) :: suiteinitresults(:) + type(test_data_container), intent(inout) :: testdatacont + 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 => testdatacont%items(idata)%ptr, testresult => testresults(iselect)) + testresult%name = testdata%name + ! Dependencies in results should point to entries in suite result array + testresult%dependencies = suiteselection%rev(testdata%dependencies) + + 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) + call run_test_(testlist, testdata%identifier, ctx, runner, repr) + testresult%status = ctx%status() + call ctx%pop_failure_info(testresult%failureinfo) + deallocate(ctx) + else + if (depstatus == teststatus%skipped) then + testresult%status = teststatus%skipped + else + testresult%status = teststatus%ignored + end if + end if + + call set_repr_name_(testresults, iselect, repr, suiteinitresults) + if (allocated(repr)) deallocate(repr) + + call logger%log_test_result(testtypes%testrun, testresult) + end associate + end do + + end subroutine run_tests_ + + + !! Building up containers containing test object names and unique integer tuple identifiers. + recursive subroutine build_test_data_(items, name, identifier, dependencies, testdatacont,& + & suitedatacont) + type(test_list), intent(in) :: items + character(*), intent(in) :: name + integer, intent(in) :: identifier(:) + integer, intent(in) :: dependencies(:) + type(test_data_container), intent(inout) :: testdatacont + type(test_data_container), intent(inout) :: suitedatacont + + type(test_data) :: testdata + class(test_base), pointer :: item + integer :: ii + character(:), allocatable :: newname + integer, allocatable :: newidentifier(:), newdependencies(:) + + do ii = 1, items%size() + newidentifier = [identifier, ii] + item => items%view(ii) + if (len(name) > 0) then + newname = name // "/" // item%name + else + newname = item%name + end if + testdata = test_data(newidentifier, newname, dependencies) + select type (item) + class is (test_suite_base) + call suitedatacont%add(testdata) + ! The last element of the suitedata container is the current suite, the new dependency. + newdependencies = [suitedatacont%nitems, dependencies] + call build_test_data_(item%tests, newname, newidentifier, newdependencies, testdatacont,& + & suitedatacont) + class is (test_case_base) + call testdatacont%add(testdata) + class default + error stop "Invalid test type obtained for test item '" // newname //& + & "' (expected serial_suite_base or serial_case_base)" + end select + end do + end subroutine build_test_data_ + + + !! Initializes a test data container + subroutine init_test_data_container(this, initsize) + + !> Instance + type(test_data_container), intent(out) :: this + + !> Initial container size + integer, intent(in) :: initsize + + allocate(this%items(initsize)) + this%nitems = 0 + + end subroutine init_test_data_container + + + !! Finalizes a test data pointer + elemental subroutine final_test_data_ptr(this) + type(test_data_ptr), intent(inout) :: this + + if (associated(this%ptr)) deallocate(this%ptr) + + end subroutine final_test_data_ptr + + + !! Appends an item to the container. + subroutine test_data_container_add(this, testdata) + class(test_data_container), intent(inout) :: this + type(test_data), intent(in) :: testdata + + integer :: newsize + type(test_data_ptr), allocatable :: buffer(:) + + if (size(this%items) == this%nitems) then + call move_alloc(this%items, buffer) + newsize = max(int(this%nitems * 1.3), this%nitems + 10) + allocate(this%items(newsize)) + this%items(1 : this%nitems) = buffer + end if + allocate(this%items(this%nitems + 1)%ptr, source=testdata) + this%nitems = this%nitems + 1 + + end subroutine test_data_container_add + + + !! Runs a test with a given identifier. + recursive subroutine run_test_(testlist, identifier, ctx, runner, repr) + type(test_list), intent(inout) :: testlist + integer, intent(in) :: identifier(:) + class(test_context), target, intent(inout) :: ctx + class(test_runner), intent(inout) :: runner + character(:), allocatable, intent(out) :: repr + + class(test_base), pointer :: scopeptr, item + class(char_rep), allocatable :: state + + scopeptr => testlist%view(identifier(1)) + call ctx%push_scope_ptr(scopeptr) + if (size(identifier) == 1) then + item => testlist%view(identifier(1)) + select type (item) + class is (test_case_base) + call runner%run_test(item, ctx) + call ctx%pop_state(state) + if (allocated(state)) repr = state%as_char() + class default + error stop "Internal error, unexpected test type in run_test_" + end select + else + item => testlist%view(identifier(1)) + select type (item) + class is (test_suite_base) + call run_test_(item%tests, identifier(2:), ctx, runner, repr) + class default + error stop "Internal error, unexpected test type in run_test_" + end select + end if + + end subroutine run_test_ + + + !! Initialize of finalize a test suite with a given identifier. + recursive subroutine initialize_finalize_suite_(testlist, identifier, init, ctx, runner, repr) + type(test_list), intent(inout) :: testlist + integer, intent(in) :: identifier(:) + logical, intent(in) :: init + class(test_context), target, intent(inout) :: ctx + class(test_runner), intent(inout) :: runner + character(:), allocatable, intent(out) :: repr + + class(test_base), pointer :: scopeptr, item + class(char_rep), allocatable :: state + + scopeptr => testlist%view(identifier(1)) + call ctx%push_scope_ptr(scopeptr) + item => testlist%view(identifier(1)) + select type (item) + class is (test_suite_base) + if (size(identifier) == 1) then + if (init) then + call runner%set_up_suite(item, ctx) + call ctx%pop_state(state) + if (allocated(state)) repr = state%as_char() + else + call runner%tear_down_suite(item, ctx) + end if + else + call initialize_finalize_suite_(item%tests, identifier(2:), init, ctx, runner, repr) + end if + class default + error stop "Internal error, unexpected test type in initialize_finalize_suite_" + end select + + end subroutine initialize_finalize_suite_ + + + !! Sets the reprname field of a given test result + subroutine set_repr_name_(testresults, ind, repr, dependencyresults) + type(test_result), target, intent(inout) :: testresults(:) + integer, intent(in) :: ind + character(:), allocatable, intent(in) :: repr + type(test_result), target, optional, intent(in) :: dependencyresults(:) + + type(test_result), pointer :: depresults(:) + character(:), allocatable :: name + + if (present(dependencyresults)) then + depresults => dependencyresults + else + depresults => testresults + end if + + associate (testresult => testresults(ind)) + name = basename(testresult%name) + if (allocated(repr)) name = name // "{" // repr // "}" + if (size(testresult%dependencies) > 0) then + testresult%reprname = depresults(testresult%dependencies(1))%reprname // "/" // name + else + testresult%reprname = name + end if + end associate + + end subroutine set_repr_name_ + + + !! Returns indices of selected suites and tests. + subroutine get_selected_suites_and_tests_(suitedatacont, testdatacont, suiteselection,& + & testselection, selections) + type(test_data_container), intent(in) :: suitedatacont, testdatacont + type(reversible_mapping), intent(out) :: suiteselection, testselection + type(test_selection), optional, intent(in) :: selections(:) + + logical, allocatable :: testmask(:), suitemask(:) + logical :: hasselection, selected, isincluded + integer :: iselect, itest + integer :: selectnamelen + integer :: ii + + hasselection = present(selections) + if (hasselection) hasselection = size(selections) > 0 + if (.not. hasselection) then + suiteselection%fwd = [(ii, ii = 1, suitedatacont%nitems)] + suiteselection%rev = suiteselection%fwd + testselection%fwd = [(ii, ii = 1, testdatacont%nitems)] + testselection%rev = testselection%fwd + return + end if + + allocate(testmask(testdatacont%nitems)) + ! If first option is an exclusion, include all tests by default otherwise exclude them. + testmask(:) = selections(1)%selectiontype == "-" + do iselect = 1, size(selections) + associate(selection => selections(iselect)) + isincluded = selection%selectiontype == "+" + selectnamelen = len(selection%name) + do itest = 1, testdatacont%nitems + associate (testdata => testdatacont%items(itest)%ptr) + if (len(testdata%name) == selectnamelen) then + selected = testdata%name == selection%name + else if (len(testdata%name) > selectnamelen) then + selected = testdata%name(:selectnamelen) == selection%name& + & .and. testdata%name(selectnamelen + 1 : selectnamelen + 1) == "/" + else + selected = .false. + end if + if (selected) testmask(itest) = isincluded + end associate + end do + end associate + end do + + allocate(suitemask(suitedatacont%nitems), source=.false.) + do itest = 1, testdatacont%nitems + if (testmask(itest)) suitemask(testdatacont%items(itest)%ptr%dependencies) = .true. + end do + + call get_rev_map_from_mask_(suitemask, suiteselection) + call get_rev_map_from_mask_(testmask, testselection) + + end subroutine get_selected_suites_and_tests_ + + + !! Creates a forward/backward map based on a (selection) mask. + 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 diff --git a/src/fortuno/testinfo.f90 b/src/fortuno/testinfo.f90 new file mode 100644 index 0000000..0e4c0ec --- /dev/null +++ b/src/fortuno/testinfo.f90 @@ -0,0 +1,222 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Types containing informations about tests and checks +module fortuno_testinfo + use fortuno_chartypes, only : char_rep + use fortuno_utils, only : as_char + implicit none + + private + public :: check_result, failure_info, test_result + public :: init_failure_location, failure_location + public :: init_drive_result, drive_result + public :: teststatus, nteststatusvals + + + !! Possible values for test status. + type :: test_status_enum_ + integer :: notrun = 1 + integer :: succeeded = 2 + integer :: failed = 3 + integer :: skipped = 4 + integer :: ignored = 5 + end type test_status_enum_ + + !> Possible test status values with following fields: + !! + !! notrun: test was not considered to be run yet + !! succeeded: test was run and no error happened + !! ignored: test had not been run due to previous errors (e.g. suite initializer failed) + !! failed: test was run and some errors occured (e.g. check failed) + !! skipped: test was deliberately skipped (e.g. skipped() called or initial conditions not met) + !! + type(test_status_enum_), parameter :: teststatus = test_status_enum_() + + !> Nr. of possible values for a test status (nr. of field in the teststatus instance) + integer, parameter :: nteststatusvals = 5 + + + !> Contains the result of a check + type :: check_result + + !> Whether the check was successful + logical :: success = .false. + + !> Further character representable information about the check (reason of failure) + class(char_rep), allocatable :: details + + end type check_result + + + !> Location of the failure, to be extended by specific drivers depending on available information + type :: failure_location + + !> Source file containin the check + character(:), allocatable :: file + + !> Line number of the check + integer :: line = 0 + + !> Check number (order number within context), zero if failure was not due to a failing check + integer :: checknr = 0 + + contains + procedure :: as_char => failure_location_as_char + end type failure_location + + + !> Contains all collected information about failed check(s) + type :: failure_info + + !> Message associated with the check, usually provided by the user + character(:), allocatable :: message + + !> Failure location information + class(failure_location), allocatable :: location + + !> Character representable internal details of the check + class(char_rep), allocatable :: details + + !> Contains previous failure_info (to be able to chain check infos) + type(failure_info), allocatable :: previous + + end type failure_info + + + !> Represents the result of a test case or an initializer/finalizer of a test suite + type :: test_result + + !> Name of the test + character(:), allocatable :: name + + !> Name of the test containing also the internal representation of the components, if present + character(:), allocatable :: reprname + + !> Final status of the test + integer :: status = teststatus%notrun + + !> Information about the failure (in case the test failed) + type(failure_info), allocatable :: failureinfo + + !> Indices of the dependencies, the immediate dependency (containing suite) first + integer, allocatable :: dependencies(:) + + end type test_result + + + !> Contains all results obtained after tests had been driven via a driver + type :: drive_result + + !> Results of the individual test runs + type(test_result), allocatable :: testresults(:) + + !> Results of the suite set-ups (1,:) and tear-downs (2, :) + type(test_result), allocatable :: suiteresults(:,:) + + !> Whether the test run was successful (all tests either successful or skipped) + logical :: successful = .false. + + !> Nr. of suite results with given status, shape (nteststatusvalue, 2) + integer, allocatable :: suitestats(:,:) + + !> Nr. of test results with given status, shape (nteststatusvalue,) + integer, allocatable :: teststats(:) + + contains + + procedure :: calculate_stats => drive_result_calculate_stats + + end type drive_result + +contains + + + !> Initializes a failure location instance + subroutine init_failure_location(this, checknr, file, line) + + !> Instance + type(failure_location), intent(out) :: this + + !> Nr. of checks made so far + integer, intent(in) :: checknr + + !> File where failure occured (if available) + character(*), optional, intent(in) :: file + + !> Line where failure occured (if available) + integer, optional, intent(in) :: line + + this%checknr = checknr + if (present(file)) this%file = file + if (present(line)) this%line = line + + end subroutine init_failure_location + + + !> Character representation of the failure location + function failure_location_as_char(this) result(repr) + + !> Instance + class(failure_location), intent(in) :: this + + !> Character representation + character(:), allocatable :: repr + + if (allocated(this%file)) then + repr = "File: " // this%file + if (this%line /= 0) then + repr = repr // " (line " // as_char(this%line) // ")" + else if (this%checknr /= 0) then + repr = repr // " (check " // as_char(this%checknr) // ")" + end if + else if (this%checknr /= 0) then + repr = "Check: " // as_char(this%checknr) + else + repr = "" + end if + + end function failure_location_as_char + + + !> Initializes the fields of an drive result instance + subroutine init_drive_result(this, nsuites, ntests) + type(drive_result), intent(out) :: this + integer, intent(in) :: nsuites, ntests + + allocate(this%suiteresults(2, nsuites)) + allocate(this%testresults(ntests)) + allocate(this%suitestats(nteststatusvals, 2), source=0) + allocate(this%teststats(nteststatusvals), source=0) + + end subroutine init_drive_result + + + !> Calculates the statistics using the already stored results + subroutine drive_result_calculate_stats(this) + + !> Instance + class(drive_result), intent(inout) :: this + + integer :: ii + logical :: testsok, suitesok(2) + + do ii = 1, nteststatusvals + this%suitestats(ii, 1) = count(this%suiteresults(1, :)%status == ii) + this%suitestats(ii, 2) = count(this%suiteresults(2, :)%status == ii) + this%teststats(ii) = count(this%testresults(:)%status == ii) + end do + do ii = 1, 2 + associate(stats => this%suitestats(:, ii)) + suitesok(ii) = stats(teststatus%succeeded) + stats(teststatus%skipped) == sum(stats) + end associate + end do + associate(stats => this%teststats) + testsok = stats(teststatus%succeeded) + stats(teststatus%skipped) == sum(stats) + end associate + this%successful = suitesok(1) .and. suitesok(2) .and. testsok + + end subroutine drive_result_calculate_stats + +end module fortuno_testinfo diff --git a/src/fortuno/testlogger.f90 b/src/fortuno/testlogger.f90 new file mode 100644 index 0000000..9bb601a --- /dev/null +++ b/src/fortuno/testlogger.f90 @@ -0,0 +1,151 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains a generic logger to be overriden by specific implementations +module fortuno_testlogger + use fortuno_testinfo, only : drive_result, test_result + implicit none + + private + public :: test_logger, testtypes + + + !! Helper type for testtypes. + type :: test_types_enum_ + integer :: suitesetup = 1 + integer :: suiteteardown = 2 + integer :: testrun = 3 + end type test_types_enum_ + + !> Contains possible choices for the origin of a test result object + !! + !! Possible fields are: + !! * suitesetup -- result of a set_up() routine of a test suite + !! * suiteteardown -- result of a tear_down() routine of a test suite + !! * testrun -- result of a test_case run() routine. + !! + type(test_types_enum_), parameter :: testtypes = test_types_enum_() + + + !> Contains the definition of a generic test logger + type, abstract :: test_logger + contains + procedure(test_logger_log_message), deferred :: log_message + procedure(test_logger_log_error), deferred :: log_error + procedure(test_logger_start_drive), deferred :: start_drive + procedure(test_logger_end_drive), deferred :: end_drive + procedure(test_logger_start_tests), deferred :: start_tests + procedure(test_logger_end_tests), deferred :: end_tests + procedure(test_logger_log_test_result), deferred :: log_test_result + procedure(test_logger_log_drive_result), deferred :: log_drive_result + end type test_logger + + + abstract interface + + !> Logs a normal message + subroutine test_logger_log_message(this, message) + import test_logger + implicit none + + !> Instance + class(test_logger), intent(inout) :: this + + !> Message to log + character(*), intent(in) :: message + + end subroutine test_logger_log_message + + + !> Logs an error message + subroutine test_logger_log_error(this, message) + import test_logger + implicit none + + !> Instance + class(test_logger), intent(inout) :: this + + !> Message to log + character(*), intent(in) :: message + + end subroutine test_logger_log_error + + + !> Called when the test drive starts (e.g. for printing headers) + subroutine test_logger_start_drive(this) + import test_logger + implicit none + + !> Instance + class(test_logger), intent(inout) :: this + + end subroutine test_logger_start_drive + + + !> Called then the test drive ended + subroutine test_logger_end_drive(this) + import test_logger + implicit none + + !> Instance + class(test_logger), intent(inout) :: this + + end subroutine test_logger_end_drive + + + !> Called immediately before the processing of the tests starts + subroutine test_logger_start_tests(this) + import test_logger + implicit none + + !> Instance + class(test_logger), intent(inout) :: this + + end subroutine test_logger_start_tests + + + !> Called after the processing of all tests had been finished + subroutine test_logger_end_tests(this) + import test_logger + implicit none + + !> Instance + class(test_logger), intent(inout) :: this + + end subroutine test_logger_end_tests + + + !> Logs the result of an individual test during processing + subroutine test_logger_log_test_result(this, testtype, testresult) + import test_logger, test_result + implicit none + + !> Instance + class(test_logger), intent(inout) :: this + + !> Type of the test to be logged (suitesetup, suiteteardown, testrun) + integer, intent(in) :: testtype + + !> Result of the test to log + type(test_result), intent(in) :: testresult + + end subroutine test_logger_log_test_result + + + !> Logs the final detailed summary after all tests test drive has finished + subroutine test_logger_log_drive_result(this, driveresult) + import test_logger, drive_result + implicit none + + !> Instance + class(test_logger), intent(inout) :: this + + !> Results of suite initializers and finalizers (shape: (2, ntestsuites)) + type(drive_result), intent(in) :: driveresult + + end subroutine test_logger_log_drive_result + + end interface + +end module fortuno_testlogger \ No newline at end of file diff --git a/src/fortuno/utils.f90 b/src/fortuno/utils.f90 new file mode 100644 index 0000000..0dc4500 --- /dev/null +++ b/src/fortuno/utils.f90 @@ -0,0 +1,126 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Various helper utilities for the different modules +module fortuno_utils + use iso_fortran_env, only : stderr => error_unit, stdout => output_unit + implicit none + + private + public :: ansicolors + public :: as_char + public :: basename + public :: nl + public :: stderr, stdout + public :: string, string_list + public :: as_upper + + !> New line character + character(*), parameter :: nl = new_line("") + + !! Helper type for listing ansi terminal colors + type :: ansi_colors_enum_ + character(4) :: default = char(27) // "[0m" + character(5) :: red = char(27) // "[31m" + character(5) :: green = char(27) // "[32m" + character(5) :: yellow = char(27) // "[33m" + character(5) :: blue = char(27) // "[34m" + character(5) :: magenta = char(27) // "[35m" + character(5) :: cyan = char(27) // "[36m" + character(5) :: white = char(27) // "[37m" + end type ansi_colors_enum_ + + !> Contains a list of ansi colors to use in Fortuno + !! + !! Supports currently (default, red, green, yellow, magenta, cyan and white) + !! + type(ansi_colors_enum_), parameter :: ansicolors = ansi_colors_enum_() + + + interface as_char + module procedure integer_as_char + end interface as_char + + + !> Minimalistic string type + type :: string + + !> Actual content of the string + character(:), allocatable :: content + + end type string + + + !> Minimalistic string list type + type :: string_list + + !> Actual items in the list + type(string), allocatable :: items(:) + + end type string_list + +contains + + !> Returns the character representation of an integer value + pure function integer_as_char(val) result(repr) + + !> Integer value to represent + integer, intent(in) :: val + + !> Character representation + character(:), allocatable :: repr + + ! should be enough to represent up to 128 bit integers with sign + character(40) :: buffer + + write(buffer, "(i0)") val + repr = trim(buffer) + + end function integer_as_char + + + !> Returns the last component (base name) of a slash ("/") separated path + pure function basename(path) + + !> Path to split + character(*), intent(in) :: path + + !> The basename + character(:), allocatable :: basename + + integer :: lastseppos + + lastseppos = index(path, "/", back=.true.) + basename = path(lastseppos + 1 :) + + end function basename + + + !> Converts a string to upper-case. + pure function as_upper(str) result(upperstr) + + !> String to convert + character(*), intent(in) :: str + + !> Upper-case string + character(len(str)) :: upperstr + + integer, parameter :: lowerstart = iachar("a") + integer, parameter :: lowerend = iachar("z") + integer, parameter :: shift = iachar("A") - lowerstart + + integer :: ii, ord + + do ii = 1, len(str) + ord = iachar(str(ii:ii)) + if (ord >= lowerstart .and. ord <= lowerend) then + upperstr(ii:ii) = achar(iachar(str(ii:ii)) + shift) + else + upperstr(ii:ii) = str(ii:ii) + end if + end do + + end function as_upper + +end module fortuno_utils \ No newline at end of file diff --git a/src/fortuno/version.f90 b/src/fortuno/version.f90 new file mode 100644 index 0000000..3b05ace --- /dev/null +++ b/src/fortuno/version.f90 @@ -0,0 +1,30 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains version information +module fortuno_version + use fortuno_utils, only : as_char + implicit none + + private + public :: versions + public :: version_string + + !> Major, minor and patch version numbers + integer, parameter :: versions(3) = [0, 1, 0] + +contains + + !> Returns the character representation of the current version + function version_string() result(versionstr) + + !> Character representation of the version + character(:), allocatable :: versionstr + + versionstr = as_char(versions(1)) // "." // as_char(versions(2)) + if (versions(3) /= 0) versionstr = versionstr // "." // as_char(versions(3)) + + end function version_string + +end module fortuno_version diff --git a/src/fortuno_serial.f90 b/src/fortuno_serial.f90 new file mode 100644 index 0000000..8b0af3a --- /dev/null +++ b/src/fortuno_serial.f90 @@ -0,0 +1,17 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Interface module for the Fortuno testing framework with the serial interface. +module fortuno_serial + use fortuno + use fortuno_serial_serialbasetypes, only : serial_case_base, serial_suite_base + use fortuno_serial_serialcmdapp, only : execute_serial_cmd_app, init_serial_cmd_app,& + & serial_cmd_app + use fortuno_serial_serialglobalctx, only : serial_check, serial_check_failed, serial_failed,& + & serial_scope_pointers, serial_skip, serial_store_state + use fortuno_serial_serialcase, only : serial_case, serial_case_item + use fortuno_serial_serialsuite, only : serial_suite, serial_suite_item + implicit none + +end module fortuno_serial diff --git a/src/fortuno_serial/serialbasetypes.f90 b/src/fortuno_serial/serialbasetypes.f90 new file mode 100644 index 0000000..86efb16 --- /dev/null +++ b/src/fortuno_serial/serialbasetypes.f90 @@ -0,0 +1,98 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains base type for serial test suites +module fortuno_serial_serialbasetypes + use fortuno, only : test_case_base, test_suite_base + implicit none + + private + public :: serial_case_base, serial_case_base_run, as_serial_case_base + public :: serial_suite_base, as_serial_suite_base + + + !> Base class for all serial test cases + type, extends(test_case_base), abstract :: serial_case_base + contains + !> Procedure to be invoked by the driver to run the test + procedure(serial_case_base_run), deferred :: run + end type serial_case_base + + + abstract interface + + subroutine serial_case_base_run(this) + import serial_case_base + implicit none + class(serial_case_base), intent(in) :: this + end subroutine serial_case_base_run + + end interface + + + !> Base type for all serial test suites + type, extends(test_suite_base), abstract :: serial_suite_base + contains + procedure :: set_up => serial_suite_base_set_up + procedure :: tear_down => serial_suite_base_tear_down + end type serial_suite_base + +contains + + !> Returns a serial_context class pointer to a generic context pointer + function as_serial_case_base(trg) result(ptr) + + !> Target to point at + class(test_case_base), pointer, intent(in) :: trg + + !> Class specific pointer + class(serial_case_base), pointer :: ptr + + select type (trg) + class is (serial_case_base) + ptr => trg + class default + error stop "Invalid test context type obtained in as_serial_case_base" + end select + + end function as_serial_case_base + + + !> Returns a serial_context class pointer to a generic context pointer + function as_serial_suite_base(trg) result(ptr) + + !> Target to point at + class(test_suite_base), pointer, intent(in) :: trg + + !> Class specific pointer + class(serial_suite_base), pointer :: ptr + + select type (trg) + class is (serial_suite_base) + ptr => trg + class default + error stop "Invalid test context type obtained in as_serial_suite_base" + end select + + end function as_serial_suite_base + + + !> Sets up the test suite, before the first test in the suite is run + subroutine serial_suite_base_set_up(this) + + !> Instance + class(serial_suite_base), intent(inout) :: this + + end subroutine serial_suite_base_set_up + + + !> Tears downs the test suite, after the last test had been run + subroutine serial_suite_base_tear_down(this) + + !> Instance + class(serial_suite_base), intent(inout) :: this + + end subroutine serial_suite_base_tear_down + +end module fortuno_serial_serialbasetypes diff --git a/src/fortuno_serial/serialcase.f90 b/src/fortuno_serial/serialcase.f90 new file mode 100644 index 0000000..90495a8 --- /dev/null +++ b/src/fortuno_serial/serialcase.f90 @@ -0,0 +1,60 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains the simplest possible parameterless serial test implementation +module fortuno_serial_serialcase + use fortuno, only : test_item + use fortuno_serial_serialbasetypes, only : serial_case_base + implicit none + + private + public :: serial_case, serial_case_item + + + !> Serial test case with simple (parameterless) test procedure + type, extends(serial_case_base) :: serial_case + + !> Test procedure to call when test is run + procedure(serial_case_proc), nopass, pointer :: proc => null() + + contains + + !> Runs the test case + procedure, public :: run => serial_case_run + + end type serial_case + + + abstract interface + + !> Simple parameterless test procedure + subroutine serial_case_proc() + end subroutine serial_case_proc + + end interface + +contains + + !> Creates a serial test case as a generic test item + function serial_case_item(name, proc) result(testitem) + character(len=*), intent(in) :: name + procedure(serial_case_proc) :: proc + type(test_item) :: testitem + + call testitem%init(serial_case(name=name, proc=proc)) + + end function serial_case_item + + + !> Runs the test case, by invoking the registered test procedure + subroutine serial_case_run(this) + + !> Instance + class(serial_case), intent(in) :: this + + call this%proc() + + end subroutine serial_case_run + +end module fortuno_serial_serialcase diff --git a/src/fortuno_serial/serialcmdapp.f90 b/src/fortuno_serial/serialcmdapp.f90 new file mode 100644 index 0000000..5a79e7f --- /dev/null +++ b/src/fortuno_serial/serialcmdapp.f90 @@ -0,0 +1,73 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains the command line app for driving serial tests +module fortuno_serial_serialcmdapp + use fortuno, only : cmd_app, test_list + use fortuno_serial_serialdriver, only : init_serial_driver, serial_driver + use fortuno_serial_serialconlogger, only : serial_console_logger + implicit none + + private + public :: init_serial_cmd_app, serial_cmd_app + public :: execute_serial_cmd_app, run_serial_cmd_app + + + !> App for driving serial tests through command line app + type, extends(cmd_app) :: serial_cmd_app + end type serial_cmd_app + +contains + + + !> Executes the serial command line app + !! + !! Note: This routine stops the code during execution and never returns. + !! + subroutine execute_serial_cmd_app(tests) + + !> Items to be considered by the app + type(test_list), intent(in) :: tests + + integer :: exitcode + + call run_serial_cmd_app(tests, exitcode) + stop exitcode, quiet=.true. + + end subroutine execute_serial_cmd_app + + + !> Convenience wrapper setting up and running the serial command line app. + subroutine run_serial_cmd_app(tests, exitcode) + + !> Items to be considered by the app + type(test_list), intent(in) :: tests + + !> Exit code the run should generate + integer, intent(out) :: exitcode + + type(serial_cmd_app) :: app + + call init_serial_cmd_app(app) + call app%run(tests, exitcode) + + end subroutine run_serial_cmd_app + + + !> Set up the serial command line app + subroutine init_serial_cmd_app(this) + + !> Instance + type(serial_cmd_app), intent(out) :: this + + type(serial_driver), allocatable :: driver + + allocate(serial_console_logger :: this%logger) + allocate(driver) + call init_serial_driver(driver) + call move_alloc(driver, this%driver) + + end subroutine init_serial_cmd_app + +end module fortuno_serial_serialcmdapp diff --git a/src/fortuno_serial/serialconlogger.f90 b/src/fortuno_serial/serialconlogger.f90 new file mode 100644 index 0000000..a62100a --- /dev/null +++ b/src/fortuno_serial/serialconlogger.f90 @@ -0,0 +1,18 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains a serial logger implementation +module fortuno_serial_serialconlogger + use fortuno, only : console_logger + implicit none + + private + public :: serial_console_logger + + + !> Serial logger + type, extends(console_logger) :: serial_console_logger + end type serial_console_logger + +end module fortuno_serial_serialconlogger \ No newline at end of file diff --git a/src/fortuno_serial/serialcontext.f90 b/src/fortuno_serial/serialcontext.f90 new file mode 100644 index 0000000..cfeff12 --- /dev/null +++ b/src/fortuno_serial/serialcontext.f90 @@ -0,0 +1,60 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Serial driver specific context +module fortuno_serial_serialcontext + use fortuno, only : context_factory, test_context + implicit none + + private + public :: as_serial_context, serial_context + public :: serial_context_factory + + + !> Context used by tests driven through the serial driver + type, extends(test_context) :: serial_context + end type serial_context + + + !> Factory to create serial context instances + type, extends(context_factory) :: serial_context_factory + contains + procedure :: create_context => serial_context_factory_create_context + end type serial_context_factory + +contains + + !> Returns a serial_context class pointer to a generic context pointer + function as_serial_context(trg) result(ptr) + + !> Target to point at + class(test_context), pointer, intent(in) :: trg + + !> Class specific pointer + type(serial_context), pointer :: ptr + + select type (trg) + type is (serial_context) + ptr => trg + class default + error stop "Invalid test context type obtained in as_serial_context" + end select + + end function as_serial_context + + + !> Creates a serial context instance + subroutine serial_context_factory_create_context(this, ctx) + + !> Instance + class(serial_context_factory), intent(inout) :: this + + !> Created context on exit + class(test_context), allocatable, intent(out) :: ctx + + allocate(serial_context :: ctx) + + end subroutine serial_context_factory_create_context + +end module fortuno_serial_serialcontext \ No newline at end of file diff --git a/src/fortuno_serial/serialdriver.f90 b/src/fortuno_serial/serialdriver.f90 new file mode 100644 index 0000000..14f29ca --- /dev/null +++ b/src/fortuno_serial/serialdriver.f90 @@ -0,0 +1,119 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Implements a driver for serial tests +module fortuno_serial_serialdriver + use fortuno, only : init_test_driver, test_case_base, test_context, test_driver,& + & test_runner, test_suite_base + use fortuno_serial_serialbasetypes, only : as_serial_case_base, as_serial_suite_base,& + & serial_case_base, serial_suite_base + use fortuno_serial_serialcontext, only : as_serial_context, serial_context, serial_context_factory + use fortuno_serial_serialglobalctx, only : set_serial_global_context + implicit none + + private + public :: init_serial_driver, serial_driver + + + !> Runner implementation for serial tests and test suites + type, extends(test_runner) :: serial_runner + contains + procedure :: set_up_suite => serial_runner_set_up_suite + procedure :: tear_down_suite => serial_runner_tear_down_suite + procedure :: run_test => serial_runner_run_test + end type serial_runner + + + !> Driver for serial tests + type, extends(test_driver) :: serial_driver + end type serial_driver + +contains + + !> Initializes a serial driver instance + subroutine init_serial_driver(this) + + !> Instance + type(serial_driver), intent(out) :: this + + type(serial_context_factory) :: ctxfactory + type(serial_runner) :: runner + + call init_test_driver(this%test_driver, ctxfactory, runner) + + end subroutine init_serial_driver + + + !> Sets up a serial test suite + subroutine serial_runner_set_up_suite(this, testsuite, ctx) + + !> Instance + class(serial_runner), intent(in) :: this + + !> Test suite to set up + class(test_suite_base), pointer, intent(in) :: testsuite + + !> Context to use + class(test_context), pointer, intent(in) :: ctx + + type(serial_context), pointer :: pctx, poldctx + class(serial_suite_base), pointer :: psuite + + pctx => as_serial_context(ctx) + psuite => as_serial_suite_base(testsuite) + call set_serial_global_context(pctx, oldctx=poldctx) + call psuite%set_up() + call set_serial_global_context(poldctx) + + end subroutine serial_runner_set_up_suite + + + !> Sets up a serial test suite + subroutine serial_runner_tear_down_suite(this, testsuite, ctx) + + !> Instance + class(serial_runner), intent(in) :: this + + !> Test suite to tear down + class(test_suite_base), pointer, intent(in) :: testsuite + + !> Context to use + class(test_context), pointer, intent(in) :: ctx + + type(serial_context), pointer :: pctx, poldctx + class(serial_suite_base), pointer :: psuite + + pctx => as_serial_context(ctx) + psuite => as_serial_suite_base(testsuite) + call set_serial_global_context(pctx, oldctx=poldctx) + call psuite%tear_down() + call set_serial_global_context(poldctx) + + end subroutine serial_runner_tear_down_suite + + + !> Runs a test case + subroutine serial_runner_run_test(this, test, ctx) + + !> Instance + class(serial_runner), intent(in) :: this + + !> Test suite to tear down + class(test_case_base), pointer, intent(in) :: test + + !> Context to use + class(test_context), pointer, intent(in) :: ctx + + type(serial_context), pointer :: pctx, poldctx + class(serial_case_base), pointer :: ptest + + pctx => as_serial_context(ctx) + ptest => as_serial_case_base(test) + call set_serial_global_context(pctx, oldctx=poldctx) + call ptest%run() + call set_serial_global_context(poldctx) + + end subroutine serial_runner_run_test + +end module fortuno_serial_serialdriver \ No newline at end of file diff --git a/src/fortuno_serial/serialglobalctx.f90 b/src/fortuno_serial/serialglobalctx.f90 new file mode 100644 index 0000000..4b87558 --- /dev/null +++ b/src/fortuno_serial/serialglobalctx.f90 @@ -0,0 +1,135 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Global serial context to avoid explicit passing of context when using non-threaded serial driver +module fortuno_serial_serialglobalctx + use fortuno, only : check_result, char_rep, test_ptr_item + use fortuno_serial_serialcontext, only : serial_context + implicit none + + private + public :: serialglobalctx + public :: set_serial_global_context + public :: serial_check, serial_check_failed, serial_failed, serial_skip, serial_store_state + public :: serial_scope_pointers + + + !> Generic check interface accessing the global context + interface serial_check + module procedure serial_check_logical, serial_check_check_result + end interface serial_check + + + !> The global context + type(serial_context), pointer, protected :: serialglobalctx => null() + +contains + + !> Sets the global context + subroutine set_serial_global_context(newctx, oldctx) + + !> New context to use as global context + type(serial_context), pointer, intent(in) :: newctx + + !> Old context used so far as global context + type(serial_context), pointer, optional, intent(out) :: oldctx + + if (present(oldctx)) oldctx => serialglobalctx + serialglobalctx => newctx + + end subroutine set_serial_global_context + + + !> Check using global context logical input + subroutine serial_check_logical(cond, msg, file, line) + + !> Whether check condition is fulfilled (check is successful) + logical, intent(in) :: cond + + !> Check message + character(*), optional, intent(in) :: msg + + !> Source file name + character(*), optional, intent(in) :: file + + !> Line information + integer, optional, intent(in) :: line + + call serialglobalctx%check(cond, msg=msg, file=file, line=line) + + end subroutine serial_check_logical + + + !> Check using global context check_result input + subroutine serial_check_check_result(checkresult, msg, file, line) + + !> Whether check condition is fulfilled (check is successful) + type(check_result), intent(in) :: checkresult + + !> Check message + character(*), optional, intent(in) :: msg + + !> Source file name + character(*), optional, intent(in) :: file + + !> Line information + integer, optional, intent(in) :: line + + call serialglobalctx%check(checkresult, msg=msg, file=file, line=line) + + end subroutine serial_check_check_result + + + !> Whether the last check has failed + function serial_check_failed() result(check_failed) + + !> True, if last check has failed + logical :: check_failed + + check_failed = serialglobalctx%check_failed() + + end function serial_check_failed + + + !> Whether the test/context has failed + function serial_failed() result(failed) + + !> True, if test has failed already (e.g. due to previous failing checks) + logical :: failed + + failed = serialglobalctx%failed() + + end function serial_failed + + + !> Mark current test/context as skipped + subroutine serial_skip() + + call serialglobalctx%skip() + + end subroutine serial_skip + + + !> Returns the enclosing suite pointers + function serial_scope_pointers() result(scopeptrs) + + !> Pointers to enclosing suites + type(test_ptr_item), allocatable :: scopeptrs(:) + + scopeptrs = serialglobalctx%scope_pointers() + + end function serial_scope_pointers + + + !> Stores the test state for later introspection + subroutine serial_store_state(state) + + !> State to store + class(char_rep), intent(in) :: state + + call serialglobalctx%store_state(state) + + end subroutine serial_store_state + +end module fortuno_serial_serialglobalctx diff --git a/src/fortuno_serial/serialsuite.f90 b/src/fortuno_serial/serialsuite.f90 new file mode 100644 index 0000000..89fb5d3 --- /dev/null +++ b/src/fortuno_serial/serialsuite.f90 @@ -0,0 +1,31 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Contains a trivial implementation for a serial suite +module fortuno_serial_serialsuite + use fortuno, only : test_item, test_list + use fortuno_serial_serialbasetypes, only : serial_suite_base + implicit none + + private + public :: serial_suite, serial_suite_item + + + !> Base type for all serial suites + type, extends(serial_suite_base) :: serial_suite + end type serial_suite + +contains + + !> Returns a serial suite instance wrapped as test_item + function serial_suite_item(name, tests) result(testitem) + character(*), intent(in) :: name + type(test_list), intent(in) :: tests + type(test_item) :: testitem + + call testitem%init(serial_suite(name=name, tests=tests)) + + end function serial_suite_item + +end module fortuno_serial_serialsuite diff --git a/test/export/serial/app/testapp.f90 b/test/export/serial/app/testapp.f90 new file mode 100644 index 0000000..c1dcd4a --- /dev/null +++ b/test/export/serial/app/testapp.f90 @@ -0,0 +1,41 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +!> Unit tests +module testapp_serial_tests + use fortuno_serial, only : is_equal, test => serial_case_item, check => serial_check, test_list + implicit none + + private + public :: tests + +contains + + + subroutine test_success() + call check(is_equal(1, 1)) + end subroutine test_success + + + function tests() + type(test_list) :: tests + + tests = test_list([& + test("success", test_success)& + ]) + + end function tests + +end module testapp_serial_tests + + +!> Test app driving Fortuno unit tests +program testapp + use testapp_serial_tests, only : tests + use fortuno_serial, only : execute_serial_cmd_app + implicit none + + call execute_serial_cmd_app(tests()) + +end program testapp diff --git a/test/export/serial/app/testapp_fpp.F90 b/test/export/serial/app/testapp_fpp.F90 new file mode 100644 index 0000000..4b36ebc --- /dev/null +++ b/test/export/serial/app/testapp_fpp.F90 @@ -0,0 +1,43 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +#include "fortuno_serial.fpp" + +!> Unit tests +module testapp_fpp_tests + use fortuno_serial, only : is_equal, test => serial_case_item, test_item + implicit none + + private + public :: test_items + +contains + + + subroutine test_success() + CHECK(is_equal(1, 1)) + end subroutine test_success + + + function test_items() result(testitems) + type(test_item), allocatable :: testitems(:) + + testitems = [& + test("success", test_success)& + ] + + end function test_items + +end module testapp_fpp_tests + + +!> Test app driving Fortuno unit tests +program testapp_fpp + use testapp_fpp_tests, only : test_items + use fortuno_serial, only : execute_serial_cmd_app + implicit none + + call execute_serial_cmd_app(testitems=test_items()) + +end program testapp_fpp diff --git a/test/export/serial/app/testapp_fypp.fypp b/test/export/serial/app/testapp_fypp.fypp new file mode 100644 index 0000000..583cda6 --- /dev/null +++ b/test/export/serial/app/testapp_fypp.fypp @@ -0,0 +1,43 @@ +! This file is part of Fortuno. +! Licensed under the BSD-2-Clause Plus Patent license. +! SPDX-License-Identifier: BSD-2-Clause-Patent + +#:include "fortuno_serial.fypp" + +!> Unit tests +module testapp_fypp_tests + use fortuno_serial, only : is_equal, test_list + $:FORTUNO_SERIAL_IMPORTS() + implicit none + + private + public :: tests + +contains + + $:TEST("success") + @:CHECK(is_equal(1, 1)) + $:END_TEST() + + + function tests() + type(test_list) :: tests + + tests = test_list([& + $:TEST_ITEMS() + ]) + + end function tests + +end module testapp_fypp_tests + + +!> Test app driving Fortuno unit tests +program testapp_fypp + use testapp_fypp_tests, only : tests + use fortuno_serial, only : execute_serial_cmd_app + implicit none + + call execute_serial_cmd_app(tests()) + +end program testapp_fypp diff --git a/test/export/serial/fpm.toml b/test/export/serial/fpm.toml new file mode 100644 index 0000000..c8fa96a --- /dev/null +++ b/test/export/serial/fpm.toml @@ -0,0 +1,27 @@ +name = "fortuno-test-export" +version = "0.0.0" +license = "BSD-2-Clause-Patent" +author = "Fortuno authors" +maintainer = "aradi@uni-bremen.de" +copyright = "Copyright 2024, Fortuno authors" + +[build] +auto-executables = false +auto-tests = false +auto-examples = false +module-naming = false + +[install] +library = false + +[fortran] +implicit-typing = false +implicit-external = false +source-form = "free" + +[dependencies] +fortuno = { path = "../../../" } + +[[executable]] +name = "testapp" +main = "testapp.f90" \ No newline at end of file