Convert one or more TAP files to XML, similar to tap2junit but with fewer dependencies

tap-to-xunit.pl

#! /usr/bin/env perl
# Copyright (C) 2011-2013 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

# As a special exception to the GNU General Public License, if you
# distribute this file as part of a program that contains a
# configuration script generated by Autoconf, you may include it under
# the same distribution terms that you use for the rest of that program.

# ---------------------------------- #
#  Imports, static data, and setup.  #
# ---------------------------------- #

use warnings FATAL => 'all';
use strict;
use Getopt::Long ();
use TAP::Parser;
use TAP::Parser::Aggregator;

my $ME = "tap-to-xml.pl";
my $VERSION = "2018-11-29";

my $HELP = "$ME: convert TAP to xUnit XML.";

# ------------------- #
#  Global variables.  #
# ------------------- #

my @tests = ();
my @errors = ();
my $bailed_out = 0;

# ----------------- #
#  Option parsing.  #
# ----------------- #

Getopt::Long::GetOptions
  (
    'help' => sub { print $HELP; exit 0; },
    'version' => sub { print "$ME $VERSION\n"; exit 0; },
  );

# ----------------- #
#  Option parsing.  #
# ----------------- #

my $diag_string = "#";

Getopt::Long::GetOptions
  (
    'help' => sub { print $HELP; exit 0; },
    'version' => sub { print "$ME $VERSION\n"; exit 0; },
  ) or exit 1;

# ------------- #
#  Prototypes.  #
# ------------- #

sub handle_tap_bailout ($);
sub handle_tap_result($);
sub is_null_string ($);
sub main (@);
sub print_explanation($);
sub print_failure($$);
sub print_skipped($);
sub xml_escape($);

# -------------- #
#  Subroutines.  #
# -------------- #

# If the given string is undefined or empty, return true, otherwise
# return false.  This function is useful to avoid pitfalls like:
#   if ($message) { print "$message\n"; }
# which wouldn't print anything if $message is the literal "0".
sub is_null_string ($)
{
  my $str = shift;
  return ! (defined $str and length $str);
}

sub handle_tap_bailout ($)
{
  my ($bailout, $msg) = ($_[0], "Bail out!");
  $bailed_out = 1;
  $msg .= " " . $bailout->explanation
    unless is_null_string $bailout->explanation;
  push(@errors, $msg);
}

sub xml_escape($)
{
  my ($x) = @_;
  $x =~ s/&/&amp;/g;
  $x =~ s/"/&quot;/g;
  $x =~ s/</&lt;/g;
  $x =~ s/>/&gt;/g;
  return $x;
}

sub print_explanation($)
{
  my ($explanation) = @_;

  return if is_null_string $explanation;
  print xml_escape($explanation);
}

sub print_failure($$)
{
  my ($result_obj, $type) = @_;

  my $explanation = '';
  print "   <failure type=\"" . xml_escape($type) . "\" ";
  print " message=\"" . xml_escape($result_obj->explanation) . "\" "
    unless is_null_string $result_obj->explanation;
  print "/>\n";
}

sub print_skipped($)
{
  my ($result_obj) = @_;
  if (is_null_string $result_obj->explanation)
    {
      print "   <skipped/>\n";
      return;
    }

  print "   <skipped>";
  print xml_escape($result_obj->explanation);
  print "</skipped>\n";
}

sub handle_tap_result($)
{
  my ($result_obj) = @_;
  my $string = $result_obj->number;
  my $description = $result_obj->description;
  my $empty = 1;
  $string .= " $description"
    unless is_null_string $description;

  print "  <testcase name=\"" . xml_escape($string) . "\"";
  if (!$result_obj->directive)
    {
      if (!$result_obj->is_ok)
        {
          $empty = 0;
          print(">\n");
          print_failure($result_obj, "TestFailed");
        }
    }
  elsif ($result_obj->has_todo)
    {
      if ($result_obj->is_actual_ok)
        {
          $empty = 0;
          print(">\n");
          print_failure($result_obj, "TodoTestSucceeded");
        }
    }
  elsif ($result_obj->has_skip)
    {
      $empty = 0;
      print(">\n");
      if ($result_obj->is_ok)
        {
          print_skipped($result_obj);
        }
      else
        {
          print_failure($result_obj, "TestFailed");
        }
    }
  if ($empty)
    {
      print " />\n";
    }
  else
    {
      print "  </testcase>\n";
    }
}

sub main (@)
{
  print "<testsuites>\n";
  for my $file (@_)
    {
      my $fh;
      open($fh, '<', $file )
          or die "error opening TAP source file '$file': $!";

      my $iterator = TAP::Parser::Iterator::Stream->new($fh);
      my $parser = TAP::Parser->new ({iterator => $iterator });
      my $name = $file;
      $name =~ s/\.tap$//;
      $bailed_out = 0;
      @tests = ();
      @errors = ();
      while (defined (my $cur = $parser->next))
        {
          next if $bailed_out;
          handle_tap_bailout($cur) if $cur->is_bailout;
          push(@tests, $cur) if $cur->is_test;
        }

      print " <testsuite name=\"" . xml_escape($name) . "\" ";
      print "tests=\"" . $parser->tests_run . "\" ";
      print "failures=\"" . scalar($parser->failed) . "\" ";
      print "skipped=\"" . scalar($parser->skipped) . "\" ";
      print "errors=\"" . scalar(@errors) . "\">\n";
      for my $error (@errors)
        {
          print "  <error type=\"Bail out\">\n";
          print_failure($error, "");
          print " </error>";
        }
      for my $test (@tests)
        {
          handle_tap_result($test);
        }
      print " </testsuite>\n"; 
    }

  print "</testsuites>\n";
}

# ----------- #
#  Main code. #
# ----------- #

main @ARGV;

# Local Variables:
# perl-indent-level: 2
# perl-continued-statement-offset: 2
# perl-continued-brace-offset: 0
# perl-brace-offset: 0
# perl-brace-imaginary-offset: 0
# perl-label-offset: -2
# cperl-indent-level: 2
# cperl-brace-offset: 0
# cperl-continued-brace-offset: 0
# cperl-label-offset: -2
# cperl-extra-newline-before-brace: t
# cperl-merge-trailing-else: nil
# cperl-continued-statement-offset: 2
# eval: (add-hook 'write-file-hooks 'time-stamp)
# time-stamp-start: "my $VERSION = "
# time-stamp-format: "'%:y-%02m-%02d.%02H'"
# time-stamp-time-zone: "UTC"
# time-stamp-end: "; # UTC"
# End: