Support of JUnit.xml

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)') '<?xml version="1.0" encoding="UTF-8"?>', &
+        & '<testsuites' // &
+        & ' xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"' // & 
+        & ' xsi:noNamespaceSchemaLocation="JUnit.xsd"' // & 
+        & '>'
+      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)') '</testsuites>'
+    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)') &
+      & '  <testsuite' // & 
+      & ' name="' // testsuite_name // '"' // &
+      & ' package="unknown"' // &
+      & ' id="', id, '"' // &
+      & ' timestamp="' // cdate(1:4) // '-' // cdate(5:6) // '-' // cdate(7:8) &
+      &                // 'T' // ctime(1:2) // ':' // ctime(3:4) // ':' // ctime(5:6) // '"' // &
+      & ' hostname="' // trim(hostname) // '"' // &
+      !& ' tests="0"' // &
+      !& ' failures="0"' // &
+      !& ' errors="0"' // &
+      !& ' skipped="0"' // &
+      !& ' time="0.0"' // &
+      & '>', &
+      '    <properties>', &
+      '    </properties>'
+
+  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)') '  <system-out/>', '  <system-err/>', '  </testsuite>'
+
+  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 = &
+      & '    <testcase' // & 
+      & ' name="' // testcase_name // '"' // &
+      & ' classname="unknown"' // &
+      !& ' time="0.0"' // &
+      & '/>'
+
+  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 = &
+      & '    <testcase' // & 
+      & ' name="' // testcase_name // '"' // &
+      & ' classname="unknown"' // &
+      !& ' time="0.0"' // &
+      & '>'
+
+  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 // '      <system-out>' // new_line('a')
+      res = res // '           ' // stdout // new_line('a')
+      res = res // '      </system-out>' // new_line('a')
+    endif
+
+    res = res // '    </testcase>'
+
+  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 = &
+      & '      <failure' // &
+      & ' message="' // trim(message) // '"' // &
+      & ' type="unknown"' // &
+      & '/>'
+
+  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,29 +656,49 @@ 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]" &
         & // new_line("a") // "  Message: " // error%message
       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

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