File Coverage

blib/lib/TAP/DOM.pm

Criterion	Covered	Total	%
statement	227	229	99.1
branch	123	144	85.4
condition	68	83	81.9
subroutine	24	24	100.0
pod	5	5	100.0
total	447	485	92.1

package TAP::DOM;
# git description: v0.97-7-g357ca13

our $AUTHORITY = 'cpan:SCHWIGON';
# ABSTRACT: TAP as Document Object Model.
$TAP::DOM::VERSION = '0.98';
use 5.006;
use strict;
use warnings;

use TAP::DOM::Entry;
use TAP::DOM::Summary;
use TAP::DOM::DocumentData;
use TAP::DOM::Config;
use TAP::Parser;
use TAP::Parser::Aggregator;
use YAML::Syck;
use Data::Dumper;

our $IS_PLAN      = 1;
our $IS_OK        = 2;
our $IS_TEST      = 4;
our $IS_COMMENT   = 8;
our $IS_UNKNOWN   = 16;
our $IS_ACTUAL_OK = 32;
our $IS_VERSION   = 64;
our $IS_PRAGMA    = 128;
our $IS_UNPLANNED = 256;
our $IS_BAILOUT   = 512;
our $IS_YAML      = 1024;
our $HAS_SKIP     = 2048;
our $HAS_TODO     = 4096;

our @tap_dom_args = (qw(ignore
                        ignorelines
                        dontignorelines
                        usebitsets
                        disable_global_kv_data
                        put_dangling_kv_data_under_lazy_plan
                        document_data_prefix
                        document_data_ignore
                        preprocess_ignorelines
                        preprocess_tap
                        noempty_tap
                        lowercase_fieldnames
                        lowercase_fieldvalues
                        trim_fieldvalues
                     ));

use parent 'Exporter';
our @EXPORT_OK = qw( $IS_PLAN
                     $IS_OK
                     $IS_TEST
                     $IS_COMMENT
                     $IS_UNKNOWN
                     $IS_ACTUAL_OK
                     $IS_VERSION
                     $IS_PRAGMA
                     $IS_UNPLANNED
                     $IS_BAILOUT
                     $IS_YAML
                     $HAS_SKIP
                     $HAS_TODO
                  );
our %EXPORT_TAGS = (constants => [ qw( $IS_PLAN
                                       $IS_OK
                                       $IS_TEST
                                       $IS_COMMENT
                                       $IS_UNKNOWN
                                       $IS_ACTUAL_OK
                                       $IS_VERSION
                                       $IS_PRAGMA
                                       $IS_UNPLANNED
                                       $IS_BAILOUT
                                       $IS_YAML
                                       $HAS_SKIP
                                       $HAS_TODO
                                    ) ] );

our %mnemonic = (
  severity => {
    1 => 'ok',
    2 => 'ok_todo',
    3 => 'ok_skip',
    4 => 'notok_todo',
    5 => 'notok',
    6 => 'notok_skip', # forbidden TAP semantic, should never happen
  },
);

# TAP severity level definition:
#
# |--------+---------------+----------+--------------+----------+------------+----------|
# | *type* |         is_ok | has_todo | is_actual_ok | has_skip | *mnemonic* | *tapcon* |
# |--------+---------------+----------+--------------+----------+------------+----------|
# | plan   |         undef |    undef |        undef |        1 | ok_skip    |        3 |
# |--------+---------------+----------+--------------+----------+------------+----------|
# | test   |             1 |        0 |            0 |        0 | ok         |        1 |
# | test   |             1 |        1 |            1 |        0 | ok_todo    |        2 |
# | test   |             1 |        0 |            0 |        1 | ok_skip    |        3 |
# | test   |             1 |        1 |            0 |        0 | notok_todo |        4 |
# | test   |             0 |        0 |            0 |        0 | notok      |        5 |
# | test   |             0 |        0 |            0 |        1 | notok_skip |        6 |
# |--------+---------------+----------+--------------+----------+------------+----------|
# |        |               |          |              |          | missing    |        0 |
# |--------+---------------+----------+--------------+----------+------------+----------|
# | *type* |       *value* |          |              |          |            |          |
# |--------+---------------+----------+--------------+----------+------------+----------|
# | pragma | +tapdom_error |          |              |          | notok      |        5 |
# |--------+---------------+----------+--------------+----------+------------+----------|

our $severity = {};
#
#          {type} {is_ok} {has_todo} {is_actual_ok} {has_skip} = $severity;
#
$severity->{plan}    {''}        {0}            {0}        {1} = 3; # ok_skip
$severity->{test}     {1}        {0}            {0}        {0} = 1; # ok
$severity->{test}     {1}        {1}            {1}        {0} = 2; # ok_todo
$severity->{test}     {1}        {0}            {0}        {1} = 3; # ok_skip
$severity->{test}     {1}        {1}            {0}        {0} = 4; # notok_todo
$severity->{test}     {0}        {0}            {0}        {0} = 5; # notok
$severity->{test}     {0}        {0}            {0}        {1} = 6; # notok_skip

our $obvious_tap_line = qr/(1\.\.|ok\s|not\s+ok\s|#|\s|tap\s+version|pragma|Bail out!)/i;

our $noempty_tap = "pragma +tapdom_error\n# document was empty";

use Class::XSAccessor
    chained     => 1,
    accessors   => [qw( plan
                        lines
                        pragmas
                        tests_planned
                        tests_run
                        version
                        is_good_plan
                        skip_all
                        start_time
                        end_time
                        has_problems
                        exit
                        parse_errors
                        parse_errors_msgs
                        summary
                        tapdom_config
                        document_data
                     )];

sub _capture_group {
    my ($s, $n) = @_; substr($s, $-[$n], $+[$n] - $-[$n]);
}

# Optimize the TAP text before parsing it.
sub preprocess_ignorelines {
    my %args = @_;

    if ($args{tap}) {

        if (my $ignorelines = $args{ignorelines}) {
            my $dontignorelines = $args{dontignorelines};
            my $tap = $args{tap};
            if ($dontignorelines) {
                # HIGHLY EXPERIMENTAL!
                #
                # We convert the 'dontignorelines' regex into a negative-lookahead
                # condition and prepend it before the 'ignorelines'.
                #
                # Why? Because we want to utilize the cleanup in one single
                # operation as fast as the regex engine can do it.
                my $re_dontignorelines = $dontignorelines ? "(?!$dontignorelines)" : '';
                my $re_filter = qr/^$re_dontignorelines$ignorelines.*[\r\n]*/m; # the /m scope needs to be here!
                $tap =~ s/$re_filter//g;
            } else {
                $tap =~ s/^$ignorelines.*[\r\n]*//mg;
            }
            $args{tap} = $tap;
            delete $args{ignorelines}; # don't try it again during parsing later
        }
    }

    return %args
}

# Filter away obvious non-TAP lines before parsing it.
sub preprocess_tap {
    my %args = @_;

    if ($args{tap}) {
      my $tap = $args{tap};
        $tap =~ s/^(?!$obvious_tap_line).*[\r\n]*//mg;
        $args{tap} = $tap;
    }

    return %args
}

# Mark empty TAP with replacement lines
sub noempty_tap {
    my %args = @_;

    if (defined($args{tap}) and $args{tap} eq '') {
      $args{tap} = $noempty_tap;
    }
    elsif (defined($args{source}) and -z $args{source}) {
      $args{tap} = $noempty_tap;
      delete $args{source};
    }

    return %args
}

sub new {
        # hash or hash ref
        my $class = shift;
        my %args = @_ == 1 ? %{$_[0]} : @_;

        my @lines;
        my $plan;
        my $version;
        my @pragmas;
        my $bailout;
        my %document_data;
        my %dangling_kv_data;

        %args = preprocess_ignorelines(%args) if $args{preprocess_ignorelines};
        %args = preprocess_tap(%args)         if $args{preprocess_tap};
        %args = noempty_tap(%args)            if $args{noempty_tap};

        my %IGNORE      = map { $_ => 1 } @{$args{ignore}};
        my $IGNORELINES = $args{ignorelines};
        my $DONTIGNORELINES = $args{dontignorelines};
        my $USEBITSETS  = $args{usebitsets};
        my $DISABLE_GLOBAL_KV_DATA  = $args{disable_global_kv_data};
        my $PUT_DANGLING_KV_DATA_UNDER_LAZY_PLAN  = $args{put_dangling_kv_data_under_lazy_plan};
        my $DOC_DATA_PREFIX = $args{document_data_prefix} || 'Test-';
        my $DOC_DATA_IGNORE = $args{document_data_ignore};
        my $LOWERCASE_FIELDNAMES = $args{lowercase_fieldnames};
        my $LOWERCASE_FIELDVALUES = $args{lowercase_fieldvalues};
        my $TRIM_FIELDVALUES = $args{trim_fieldvalues};
        my $NOEMPTY_TAP = $args{noempty_tap};
        delete $args{ignore};
        delete $args{ignorelines};
        delete $args{dontignorelines};
        delete $args{usebitsets};
        delete $args{disable_global_kv_data};
        delete $args{put_dangling_kv_data_under_lazy_plan};
        delete $args{document_data_prefix};
        delete $args{document_data_ignore};
        delete $args{preprocess_ignorelines};
        delete $args{preprocess_tap};
        delete $args{noempty_tap};
        delete $args{lowercase_fieldnames};
        delete $args{lowercase_fieldvalues};
        delete $args{trim_fieldvalues};

        my $document_data_regex = qr/^#\s*$DOC_DATA_PREFIX([^:]+)\s*:\s*(.*)$/;
        my $document_data_ignore = defined($DOC_DATA_IGNORE) ? qr/$DOC_DATA_IGNORE/ : undef;

        my $parser = TAP::Parser->new( { %args } );

        my $aggregate = TAP::Parser::Aggregator->new;
        $aggregate->start;

        my $count_tap_lines = 0;
        my $found_pragma_tapdom_error = 0;
        while ( my $result = $parser->next ) {
                no strict 'refs';

                next if $IGNORELINES && $result->raw =~ m/$IGNORELINES/ && !($DONTIGNORELINES && $result->raw =~ m/$DONTIGNORELINES/);

                my $entry = TAP::DOM::Entry->new;
                $entry->{is_has} = 0 if $USEBITSETS;

                # test info
                foreach (qw(type raw as_string )) {
                        $entry->{$_} = $result->$_ unless $IGNORE{$_};
                }

                if ($result->is_test) {
                        foreach (qw(directive explanation number description )) {
                                $entry->{$_} = $result->$_ unless $IGNORE{$_};
                        }
                        foreach (qw(is_ok is_unplanned )) {
                                if ($USEBITSETS) {
                                        $entry->{is_has} |= $result->$_ ? ${uc $_} : 0 unless $IGNORE{$_};
                                } else {
                                        $entry->{$_} = $result->$_ ? 1 : 0 unless $IGNORE{$_};
                                }
                        }
                }

                # plan
                if ($result->is_plan) {
                  $plan = $result->as_string;
                  foreach (qw(directive explanation)) {
                          $entry->{$_} = $result->$_ unless $IGNORE{$_};
                  }

                  # save Dangling kv_data to plan entry. The situation
                  # that we already collected kv_data but haven't got
                  # a plan yet should only happen in documents with
                  # lazy plans (plan at the end).
                  if ($PUT_DANGLING_KV_DATA_UNDER_LAZY_PLAN and keys %dangling_kv_data) {
                    $entry->{kv_data}{$_} = $dangling_kv_data{$_} foreach keys %dangling_kv_data;
                  }
                }

                # meta info
                foreach ((qw(has_skip has_todo))) {
                        if ($USEBITSETS) {
                                $entry->{is_has} |= $result->$_ ? ${uc $_} : 0 unless $IGNORE{$_};
                        } else {
                                $entry->{$_} = $result->$_ ? 1 : 0 unless $IGNORE{$_};
                        }
                }
                # Idea:
                # use constants
                # map to constants
                # then loop
                foreach (qw( is_pragma is_comment is_bailout is_plan
                             is_version is_yaml is_unknown is_test))
                {
                        if ($USEBITSETS) {
                                $entry->{is_has} |= $result->$_ ? ${uc $_} : 0 unless $IGNORE{$_};
                        } else {
                                $entry->{$_} = $result->$_ ? 1 : 0 unless $IGNORE{$_};
                        }
                }
                if (! $IGNORE{is_actual_ok}) {
                        # XXX:
                        # I think it's confusing when the value of
                        # "is_actual_ok" only has a meaning when
                        # "has_todo" is true.
                        # This makes it difficult to evaluate later.
                        # But it's aligned with TAP::Parser
                        # which also sets this only on "has_todo".
                        #
                        # Maybe the problem is a general philosophical one
                        # in TAP::DOM to always have each hashkey existing.
                        # Hmmm...
                        my $is_actual_ok = ($result->has_todo && $result->is_actual_ok) ? 1 : 0;
                        if ($USEBITSETS) {
                                $entry->{is_has} |= $is_actual_ok ? $IS_ACTUAL_OK : 0;
                        } else {
                                $entry->{is_actual_ok} = $is_actual_ok;
                        }
                }
                $entry->{data}         = $result->data if $result->is_yaml && !$IGNORE{data};

                if ($result->is_comment and $result->as_string =~ $document_data_regex)
                {{ # extra block for 'last'
                        # we can't use $1, $2 because the regex could contain configured other groups
                        my ($key, $value) = (_capture_group($result->as_string, -2), _capture_group($result->as_string, -1));
                        $key =~ s/^\s+//; # strip leading  whitespace
                        $key =~ s/\s+$//; # strip trailing whitespace

                        # optional lowercase
                        $key   = lc $key   if $LOWERCASE_FIELDNAMES;
                        $value = lc $value if $LOWERCASE_FIELDVALUES;

                        # optional value trimming
                        $value =~ s/\s+$// if $TRIM_FIELDVALUES; # there can be no leading whitespace

                        # skip this field according to regex
                        last if $DOC_DATA_IGNORE and $document_data_ignore and $key =~ $document_data_ignore;

                        # Store "# Test-key: value" entries also as
                        # 'kv_data' under their parent line.
                        # That line should be a test or a plan line, so that its
                        # place (or "data path") is structurally always the same.
                        if ($lines[-1]->is_test or $lines[-1]->is_plan or $lines[-1]->is_pragma) {
                            $lines[-1]->{kv_data}{$key} = $value;
                        } else {
                            if (!$plan) {
                              # We haven't got a plan yet, so that
                              # kv_data entry would get lost. As we
                              # might still get a lazy plan at end
                              # of document, so we save it up for
                              # that potential plan entry.
                              $dangling_kv_data{$key} = $value;
                            }
                        }
                        $document_data{$key} = $value unless $lines[-1]->is_test && $DISABLE_GLOBAL_KV_DATA;
                }}

                # calculate severity
                if ($entry->{is_test} or $entry->{is_plan}) {
                  no warnings 'uninitialized';
                  $count_tap_lines++;
                  $entry->{severity} = $severity
                    ->{$entry->{type}}
                    ->{$entry->{is_ok}}
                    ->{$entry->{has_todo}}
                    ->{$entry->{is_actual_ok}}
                    ->{$entry->{has_skip}};
                }

                if ($entry->{is_pragma} or $entry->{is_unknown}) {
                  no warnings 'uninitialized';
                  if ($entry->{raw} =~ /^pragma\s+\+tapdom_error\s*$/) {
                    $found_pragma_tapdom_error=1;
                    $entry->{severity}   = 5;
                    $entry->{is_unknown} = 0;
                    $entry->{is_pragma}  = 1;
                    $entry->{type}       = 'pragma';
                  } else {
                    $entry->{severity} = 0;
                  }
                }
                $entry->{severity} = 0 if not defined $entry->{severity};

                # yaml and comments are taken as children of the line before
                if ($result->is_yaml or $result->is_comment and @lines)
                {
                        push @{ $lines[-1]->{_children} }, $entry;
                }
                else
                {
                        push @lines, $entry;
                }
        }
        @pragmas = $parser->pragmas;

        if (!$count_tap_lines and !$found_pragma_tapdom_error and $NOEMPTY_TAP) {
          # pragma +tapdom_error
          my $error_entry = TAP::DOM::Entry->new(
            'is_version'   => 0,
            'is_plan'      => 0,
            'is_test'      => 0,
            'is_comment'   => 0,
            'is_yaml'      => 0,
            'is_unknown'   => 0,
            'is_bailout'   => 0,
            'is_actual_ok' => 0,
            'is_pragma'    => 1,
            'type'         => 'pragma',
            'raw'          => 'pragma +tapdom_error',
            'as_string'    => 'pragma +tapdom_error',
            'severity'     => 5,
            'has_todo'     => 0,
            'has_skip'     => 0,
          );
          $error_entry->{is_has} = $IS_PRAGMA if $USEBITSETS;
          foreach (qw(raw type as_string explanation)) { delete $error_entry->{$_} if $IGNORE{$_} }
          # pragma +tapdom_error
          my $error_comment = TAP::DOM::Entry->new(
            'is_version'   => 0,
            'is_plan'      => 0,
            'is_test'      => 0,
            'is_comment'   => 1,
            'is_yaml'      => 0,
            'is_unknown'   => 0,
            'is_bailout'   => 0,
            'is_actual_ok' => 0,
            'is_pragma'    => 0,
            'type'         => 'comment',
            'raw'          => '# no tap lines',
            'as_string'    => '# no tap lines',
            'severity'     => 0,
            'has_todo'     => 0,
            'has_skip'     => 0,
          );
          $error_comment->{is_has} = $IS_COMMENT if $USEBITSETS;
          foreach (qw(raw type as_string explanation)) { delete $error_comment->{$_} if $IGNORE{$_} }
          $error_entry->{_children} //= [];
          push @{$error_entry->{_children}}, $error_comment;
          push @lines, $error_entry;
          push @pragmas, 'tapdom_error';
        }

        $aggregate->add( main => $parser );
        $aggregate->stop;

        my $summary = TAP::DOM::Summary->new
         (
          failed          => scalar $aggregate->failed,
          parse_errors    => scalar $aggregate->parse_errors,
          planned         => scalar $aggregate->planned,
          passed          => scalar $aggregate->passed,
          skipped         => scalar $aggregate->skipped,
          todo            => scalar $aggregate->todo,
          todo_passed     => scalar $aggregate->todo_passed,
          wait            => scalar $aggregate->wait,
          exit            => scalar $aggregate->exit,
          elapsed         => $aggregate->elapsed,
          elapsed_timestr => $aggregate->elapsed_timestr,
          all_passed      => $aggregate->all_passed ? 1 : 0,
          status          => $aggregate->get_status,
          total           => $aggregate->total,
          has_problems    => $aggregate->has_problems ? 1 : 0,
          has_errors      => $aggregate->has_errors ? 1 : 0,
         );

        my $tapdom_config = TAP::DOM::Config->new
         (
          ignore                               => \%IGNORE,
          ignorelines                          => $IGNORELINES,
          dontignorelines                      => $DONTIGNORELINES,
          usebitsets                           => $USEBITSETS,
          disable_global_kv_data               => $DISABLE_GLOBAL_KV_DATA,
          put_dangling_kv_data_under_lazy_plan => $PUT_DANGLING_KV_DATA_UNDER_LAZY_PLAN,
          document_data_prefix                 => $DOC_DATA_PREFIX,
          document_data_ignore                 => $DOC_DATA_IGNORE,
          lowercase_fieldnames                 => $LOWERCASE_FIELDNAMES,
          lowercase_fieldvalues                => $LOWERCASE_FIELDVALUES,
          trim_fieldvalues                     => $TRIM_FIELDVALUES,
          noempty_tap                          => $NOEMPTY_TAP,
         );

        my $document_data = TAP::DOM::DocumentData->new(%document_data);

        my $tapdata = {
                       plan          => $plan,
                       lines         => \@lines,
                       pragmas       => \@pragmas,
                       tests_planned => $parser->tests_planned,
                       tests_run     => $parser->tests_run,
                       version       => $parser->version,
                       is_good_plan  => $parser->is_good_plan,
                       skip_all      => $parser->skip_all,
                       start_time    => $parser->start_time,
                       end_time      => $parser->end_time,
                       has_problems  => $parser->has_problems,
                       exit          => $parser->exit,
                       parse_errors  => scalar $parser->parse_errors,
                       parse_errors_msgs  => [ $parser->parse_errors ],
                       summary       => $summary,
                       tapdom_config => $tapdom_config,
                       document_data => $document_data,
                      };
        return bless $tapdata, $class;
}

sub _entry_to_tapline
{
        my ($self, $entry) = @_;

        my %IGNORE = %{$self->{tapdom_config}{ignore}};

        my $tapline = "";

        # ok/notok test lines
        if ($entry->{is_test})
        {
                $tapline = join(" ",
                                # the original "NOT" is more difficult to reconstruct than it should...
                                ($entry->{has_todo}
                                 ? $entry->{is_actual_ok} ? () : "not"
                                 : $entry->{is_ok}        ? () : "not"),
                                "ok",
                                ($entry->{number} || ()),
                                ($entry->{description} || ()),
                                ($entry->{has_skip}   ? "# SKIP ".($entry->{explanation} || "")
                                 : $entry->{has_todo }? "# TODO ".($entry->{explanation} || "")
                                 : ()),
                               );
        }
        # pragmas and meta lines, but no version nor plan
        elsif ($entry->{is_pragma}  ||
               $entry->{is_comment} ||
               $entry->{is_bailout} ||
               $entry->{is_yaml})
        {
                $tapline = $IGNORE{raw} ? $entry->{as_string} : $entry->{raw}; # if "raw" was 'ignored' try "as_string"
        }
        return $tapline;
}

sub _lines_to_tap
{
        my ($self, $lines) = @_;

        my @taplines;
        foreach my $entry (@$lines)
        {
                my $tapline = $self->_entry_to_tapline($entry);
                push @taplines, $tapline if $tapline;
                push @taplines, $self->_lines_to_tap($entry->{_children}) if $entry->{_children};
        }
        return @taplines;
}

sub to_tap
{
    my ($self) = @_;

    my @taplines = $self->_lines_to_tap($self->{lines});
    unshift @taplines, $self->{plan};
    unshift @taplines, "TAP version ".$self->{version};

    return wantarray
      ? @taplines
      : join("\n", @taplines)."\n";
}

1; # End of TAP::DOM

__END__