diff --git a/src/testdrive.F90 b/src/testdrive.F90 index 0cd6b83..d7f9e4b 100644 --- a/src/testdrive.F90 +++ b/src/testdrive.F90 @@ -114,7 +114,16 @@ module testdrive public :: check, test_failed, skip_test public :: test_interface, collect_interface public :: get_argument, get_variable, to_string + public :: junitxml_open_file + public :: junitxml_run_testsuite + public :: junitxml_run_selected + public :: junitxml_close_file + !> Logical for activation JUnit.xml + logical :: ljunit = .false. + + !> Unit number for JUnit.xml. + integer :: unit_junitxml !> Single precision real numbers integer, parameter :: sp = selected_real_kind(6) @@ -309,6 +318,207 @@ end subroutine collect_interface contains + !> Open JUnit.xml file for CLI output of test results. + subroutine junitxml_open_file(name) + character(len=*), intent(in), optional :: name + + character(len=:), allocatable :: name_ + character(len=:), allocatable :: namexml + + name_ = '' + if (present(name)) name_ = '_'//trim(name) + + namexml = 'JUnit'//name_//'.xml' + + open(newunit=unit_junitxml, file=namexml, form='formatted', access='sequential', status='replace') + + if (unit_junitxml /= -1) then + write(unit_junitxml,'(a/,a)') '', & + & '' + ljunit = .true. + else + write(error_unit, '(a)') "# Error: Could not open "//namexml//" for writing! Program stops." + error stop 1 + endif + + end subroutine junitxml_open_file + + !> Close JUnit.xml file. + subroutine junitxml_close_file() + + write(unit_junitxml,'(a)') '' + close(unit_junitxml) + + ljunit = .false. + + end subroutine junitxml_close_file + + !> Write opening tag for testsuite with name to JUnit.xml. + subroutine junitxml_write_testsuite_opening_tag(testsuite_name, id) + + character(len=*), intent(in) :: testsuite_name + integer, intent(in) :: id + + character(len=80) :: hostname + character(len=8) :: cdate + character(len=10) :: ctime + + + call hostnm(hostname) + call date_and_time(DATE=cdate, TIME=ctime) + + write(unit_junitxml,'(a,i0,2(a/),a)') & + & ' ', & + ' ', & + ' ' + + end subroutine junitxml_write_testsuite_opening_tag + + !> Write closing tag for testsuite to JUnit.xml. + subroutine junitxml_write_testsuite_closing_tag() + + write(unit_junitxml,'(a/,a/,a)') ' ', ' ', ' ' + + end subroutine junitxml_write_testsuite_closing_tag + + !> Write single tag for testcase with name to JUnit.xml. + !> Needed, if no failure occurred and no stdout message present. + !> Shortens output to a single line in xml file. + pure function junitxml_write_testcase_single_tag(testcase_name) result(res) + + character(len=*), intent(in) :: testcase_name + character(len=:), allocatable :: res + + res = & + & ' ' + + end function junitxml_write_testcase_single_tag + + !> Write opening tag for testcase with name to JUnit.xml. Needed, if a failure occurred. + pure function junitxml_write_testcase_opening_tag(testcase_name) result(res) + + character(len=*), intent(in) :: testcase_name + character(len=:), allocatable :: res + + res = & + & ' ' + + end function junitxml_write_testcase_opening_tag + + !> Write closing tag for testcase to JUnit.xml. + pure function junitxml_write_testcase_closing_tag(stdout) result(res) + + character(len=*), intent(in) :: stdout + character(len=:), allocatable :: res + + res = '' + + if (len_trim(stdout) > 0) then + res = res // ' ' // new_line('a') + res = res // ' ' // stdout // new_line('a') + res = res // ' ' // new_line('a') + endif + + res = res // ' ' + + end function junitxml_write_testcase_closing_tag + + !> Write failure message to JUnit.xml. + pure function junitxml_write_testcase_failure(message) result(res) + + character(len=*), intent(in) :: message + character(len=:), allocatable :: res + + res = & + & ' ' + + end function junitxml_write_testcase_failure + + + !> + subroutine junitxml_run_testsuite(is, name, collect, unit, stat, parallel) + + !> + integer, intent(in) :: is + + !> + character(len=*), intent(in) :: name + + !> Collect tests + procedure(collect_interface) :: collect + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + !> Run the tests in parallel + logical, intent(in), optional :: parallel + + call junitxml_write_testsuite_opening_tag(name, is) + + call run_testsuite(collect, unit, stat, parallel) + + call junitxml_write_testsuite_closing_tag() + + end subroutine junitxml_run_testsuite + + !> + subroutine junitxml_run_selected(is, testname, collect, name, unit, stat) + + !> + integer, intent(in) :: is + + !> + character(len=*), intent(in) :: testname + + !> Collect tests + procedure(collect_interface) :: collect + + !> Name of the selected test + character(len=*), intent(in) :: name + + !> Unit for IO + integer, intent(in) :: unit + + !> Number of failed tests + integer, intent(inout) :: stat + + call junitxml_write_testsuite_opening_tag(testname, is) + + call run_selected(collect, name, unit, stat) + + call junitxml_write_testsuite_closing_tag() + + end subroutine junitxml_run_selected + !> Driver for testsuite recursive subroutine run_testsuite(collect, unit, stat, parallel) @@ -396,14 +606,20 @@ recursive subroutine run_unittest(test, unit, stat) type(error_type), allocatable :: error character(len=:), allocatable :: message + character(len=:), allocatable :: junitxml_output call test%test(error) if (.not.test_skipped(error)) then if (allocated(error) .neqv. test%should_fail) stat = stat + 1 end if - call make_output(message, test, error) + if (ljunit) then + call make_output(message, test, error, junitxml_output) + else + call make_output(message, test, error) + endif !$omp critical(testdrive_testsuite) write(unit, '(a)') message + if(allocated(junitxml_output)) write(unit_junitxml,'(a)') junitxml_output !$omp end critical(testdrive_testsuite) if (allocated(error)) then call clear_error(error) @@ -429,7 +645,7 @@ end function test_skipped !> Create output message for test (this procedure is pure and therefore cannot launch tests) - pure subroutine make_output(output, test, error) + pure subroutine make_output(output, test, error, junitxml_output) !> Output message for display character(len=:), allocatable, intent(out) :: output @@ -440,8 +656,12 @@ pure subroutine make_output(output, test, error) !> Error handling type(error_type), intent(in), optional :: error + !> Optional output for JUnit + character(len=:), allocatable, intent(out), optional :: junitxml_output + character(len=:), allocatable :: label character(len=*), parameter :: indent = repeat(" ", 7) // repeat(".", 3) // " " + character(len=:), allocatable :: stdout if (test_skipped(error)) then output = indent // test%name // " [SKIPPED]" & @@ -449,20 +669,36 @@ pure subroutine make_output(output, test, error) return end if + stdout = '' + if (present(error)) stdout = trim(error%message) + if (present(error) .neqv. test%should_fail) then if (test%should_fail) then - label = " [UNEXPECTED PASS]" + label = "UNEXPECTED PASS" else - label = " [FAILED]" + label = "FAILED" end if + if(present(junitxml_output)) junitxml_output = & + junitxml_write_testcase_opening_tag(test%name) //new_line('a') // & + junitxml_write_testcase_failure(label) //new_line('a') // & + junitxml_write_testcase_closing_tag(stdout) else if (test%should_fail) then - label = " [EXPECTED FAIL]" + label = "EXPECTED FAIL" else - label = " [PASSED]" + label = "PASSED" end if + if (present(junitxml_output)) then + if (len_trim(stdout) > 0) then + junitxml_output = & + junitxml_write_testcase_opening_tag(test%name) //new_line('a') // & + junitxml_write_testcase_closing_tag(stdout) + else + junitxml_output = junitxml_write_testcase_single_tag(test%name) + end if + end if end if - output = indent // test%name // label + output = indent // test%name // " [" // label // "]" if (present(error)) then output = output // new_line("a") // " Message: " // error%message end if diff --git a/test/main_junitxml.f90 b/test/main_junitxml.f90 new file mode 100644 index 0000000..bbb2005 --- /dev/null +++ b/test/main_junitxml.f90 @@ -0,0 +1,76 @@ +! This file is part of test-drive. +! SPDX-Identifier: Apache-2.0 OR MIT +! +! Licensed under either of Apache License, Version 2.0 or MIT license +! at your option; you may not use this file except in compliance with +! the License. +! +! Unless required by applicable law or agreed to in writing, software +! distributed under the License is distributed on an "AS IS" BASIS, +! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +! See the License for the specific language governing permissions and +! limitations under the License. + +!> Driver for unit testing +program tester_junitxml + use, intrinsic :: iso_fortran_env, only : error_unit + use testdrive, only : new_testsuite, testsuite_type, & + & select_suite, get_argument, & + & junitxml_open_file, junitxml_close_file, & + & junitxml_run_testsuite, junitxml_run_selected + use test_check, only : collect_check + use test_select, only : collect_select + implicit none + integer :: stat, is + character(len=:), allocatable :: suite_name, test_name + type(testsuite_type), allocatable :: testsuites(:) + character(len=*), parameter :: fmt = '("#", *(1x, a))' + + stat = 0 + + testsuites = [ & + new_testsuite("check", collect_check), & + new_testsuite("select", collect_select) & + ] + + call get_argument(1, suite_name) + call get_argument(2, test_name) + + call junitxml_open_file() + + if (allocated(suite_name)) then + is = select_suite(testsuites, suite_name) + if (is > 0 .and. is <= size(testsuites)) then + if (allocated(test_name)) then + write(error_unit, fmt) "Suite:", testsuites(is)%name + call junitxml_run_selected(is, testsuites(is)%name, testsuites(is)%collect, test_name, error_unit, stat) + if (stat < 0) then + error stop 1 + end if + else + write(error_unit, fmt) "Testing:", testsuites(is)%name + call junitxml_run_testsuite(is, testsuites(is)%name, testsuites(is)%collect, error_unit, stat) + end if + else + write(error_unit, fmt) "Available testsuites" + do is = 1, size(testsuites) + write(error_unit, fmt) "-", testsuites(is)%name + end do + error stop 1 + end if + else + do is = 1, size(testsuites) + write(error_unit, fmt) "Testing:", testsuites(is)%name + call junitxml_run_testsuite(is, testsuites(is)%name, testsuites(is)%collect, error_unit, stat) + end do + end if + + call junitxml_close_file() + + if (stat > 0) then + write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!" + error stop 1 + end if + + +end program tester_junitxml