File Coverage

blib/lib/TAP/Spec/Parser.pm

Criterion	Covered	Total	%
statement	138	190	72.6
branch	30	44	68.1
condition	4	12	33.3
subroutine	42	58	72.4
pod			n/a
total	214	304	70.3

package TAP::Spec::Parser;
BEGIN {
  $TAP::Spec::Parser::AUTHORITY = 'cpan:ARODLAND';
}
{
  $TAP::Spec::Parser::VERSION = '0.07_991'; # TRIAL
}
# ABSTRACT: Reference implementation of the TAP specification
use Mouse;
use Method::Signatures::Simple;
use Try::Tiny;
use Marpa::R2;
use TAP::Spec::TestSet ();

has 'exhaustive_strings' => (
  isa => 'Int',
  is => 'ro',
  default => 0,
);

has 'reader' => (
  isa => 'CodeRef',
  is => 'ro',
  required => 1,
);


# API adapters to MGC
method new_from_string ($class: $string, %args) {
  open my $fh, '<', \$string or die $!;
  my $reader = sub {
    scalar <$fh>;
  };

  $class->new(%args, reader => $reader);
}

method parse_from_string ($class: $string, %args) {
  $class->new_from_string($string, %args)->parse;
}


method new_from_handle ($class: $handle, %args) {
  my $reader = sub {
    scalar <$handle>;
  };

  $class->new(%args, reader => $reader);
}

method parse_from_handle ($class: $handle, %args) {
  $class->new_from_handle($handle, %args)->parse;
}


method new_from_file ($class: $file, %args) {
  open my $fh, '<', $file or die $!;
  my $reader = sub {
    scalar <$fh>;
  };

  $class->new(%args, reader => $reader);
}

method parse_from_file ($class: $file, %args) {
  $class->new_from_file($file, %args)->parse;
}

my $stream_grammar = Marpa::R2::Grammar->new({
  actions => 'TAP::Spec::Parser::Actions',
  start => 'Testset',
  rules => q{
    # Testset = Header (Plan Body / Body Plan) Footer
    Testset ::= Header Plan_And_Body Footer EOF  action => Testset
    Plan_And_Body ::=
        Plan Body  action => Plan_Body
      | Body Plan  action => Body_Plan

    # Header = [Comments] [Version]
    Header ::= Maybe_Comments Maybe_Version  action => Header
    Maybe_Comments ::= Comments  action => subrule1
    Maybe_Comments ::= action => undef
    Maybe_Version ::= Version  action => subrule1
    Maybe_Version ::= action => undef

    # Footer = [Comments]
    Footer ::= Maybe_Comments  action => Footer

    # Body = *(Comment / TAP-Line)
    Body ::= Body_Line*  action => Body
    Body_Line ::=
        Comment  action => subrule1
      | TAP_Line  action => subrule1

    # Comments = 1*Comment
    Comments ::= Comment+  action => Comments
  },
});
$stream_grammar->precompute;

method stream_grammar {
  $stream_grammar
}

my $line_grammar = Marpa::R2::Grammar->new({
  actions => 'TAP::Spec::Parser::Actions',
  start => 'Valid_Line',
  rules => q{
    # "Any output line that is not a version, a plan, a test line, a diagnostic
    # or a bail out is considered an 'unknown' line."
    # Valid_Line is a meta-rule that matches any valid line of TAP (a rule that
    # starts at the beginning of a line and matches EOL at the end). Any line of
    # input that doesn't match "Valid_Line" is discarded as a "junk line", so
    # keep this up to date.
    Valid_Line ::=
        TAP_Line  action => tokenize_TAP_Line
      | Version   action => tokenize_Version
      | Plan      action => tokenize_Plan
      | Comment   action => tokenize_Comment

    # Tap-Line = Test-Result / Bail-Out
    TAP_Line ::=
        Test_Result  action => subrule1
      | Bail_Out     action => subrule1

    # Version = "TAP version" SP Version-Number EOL ; ie. "TAP version 13"
    Version ::= TAP_version SP Version_Number EOL  action => Version

    # Version-Number = Positive-Integer
    Version_Number ::= Positive_Integer  action => subrule1

    # Plan = ( Plan-Simple / Plan-Todo / Plan-Skip-All ) EOL
    Plan ::=
        Plan_Simple   EOL  action => subrule1
      | Plan_Todo     EOL  action => subrule1
      | Plan_Skip_All EOL  action => subrule1

    # Plan-Simple = "1.." Number-Of-Tests
    Plan_Simple ::= Plan_Simple_Body  action => Plan_Simple
    Plan_Simple_Body ::= ONE_DOT_DOT Number_Of_Tests  action => subrule2 # Capture no. of tests

    # Plan-Todo = Plan-Simple "todo" 1*(SP Test-Number) ";" ; obsolete
    Plan_Todo ::= Plan_Simple_Body SP todo SP Test_Numbers SEMI  action => Plan_Todo
    Test_Numbers ::= Test_Number+  separator => SP proper => 1 action => Test_Numbers

    # Plan-Skip-All = "1..0" SP "skip" SP Reason
    Plan_Skip_All ::= ONE_DOT_DOT_0 SP skip SP Reason  action => Plan_Skip_All

    # Reason = String
    Reason ::= String  action => subrule1

    # Test-Number = Positive-Integer
    Test_Number ::= Positive_Integer  action => subrule1

    # Test-Result = Status [SP Test-Number] [SP Description]
    #               [SP "#" SP Directive [SP Reason]] EOL
    Test_Result ::= Status Maybe_Test_Number Maybe_Description Maybe_Directive_Reason EOL  action => Test_Result
    Maybe_Test_Number ::= SP Test_Number  action => subrule2
    Maybe_Test_Number ::= action => undef
    Maybe_Description ::= SP Description  action => subrule2
    Maybe_Description ::= action => undef
    Maybe_Directive_Reason ::= SP HASH SP Directive Maybe_Reason   action => Maybe_Directive_Reason
    Maybe_Directive_Reason ::= action => undef
    Maybe_Reason ::= SP Reason  action => subrule2
    Maybe_Reason ::= action => undef

    # Status = "ok" / "not ok"
    Status ::=
        ok      action => subrule1
      | not_ok  action => subrule1

    # Description = Safe-String
    Description ::= Safe_String  action => subrule1

    # Directive = "SKIP" / "TODO"
    Directive ::=
        SKIP  action => subrule1
      | TODO  action => subrule1

    # Bail-Out = "Bail out!" [SP Reason] EOL
    Bail_Out ::= Bail_out Maybe_Reason EOL  action => Bail_Out

    # Comment = "#" String EOL
    Comment ::= HASH String EOL  action => Comment

    # String = 1*(Safe-String / "#")
    String ::= String_Part+  action => String
    String_Part ::=
        Safe_String  action => subrule1
      | HASH         action => subrule1
  },
});
$line_grammar->precompute;

method line_grammar {
  $line_grammar
}

my %tokens = (
  'ONE_DOT_DOT'   => [ qr/\G1\.\./ ],
  'ONE_DOT_DOT_0' => [ qr/\G1\.\.0/ ],
  'TODO'          => [ qr/\GTODO/i, 'TODO' ],
  'SKIP'          => [ qr/\GSKIP/i, 'SKIP' ],
  'ok'            => [ qr/\Gok/i, 'ok' ],
  'not_ok'        => [ qr/\Gnot ok/i, 'not ok' ],
  'TAP_version'   => [ qr/\GTAP version/i ],
  'Bail_out'      => [ qr/\GBail out!/i ],
  'HASH'          => [ qr/\G#/, '#' ],
  'SEMI'          => [ qr/\G;/, ';' ],
  'SP'            => [ qr/\G /, ' ' ],

  # EOL = LF / CRLF
  'EOL' => [ qr/\G(?:\n|\r\n)/ ],

  # Safe-String = 1*(%x01-09 %x0B-0C %x0E-22 %x24-FF)  ; UTF8 without EOL or "#"
  'Safe_String' => [ qr/\G([\x01-\x09\x0b-\x0c\x0e-\x22\x24-\xff]+)/ ],

  # Positive-Integer = ("1" / "2" / "3" / "4" / "5" / "6" / "7" / "8" / "9") *DIGIT
  'Positive_Integer' => [ qr/\G([1-9][0-9]*)/, sub { 0 + $1 } ],

  # Number-Of-Tests = 1*DIGIT
  'Number_Of_Tests' => [ qr/\G(\d+)/, sub { 0 + $1 } ],
);

method lex ($input, $pos, $expected) {
  my @matches;

  TOKEN: for my $token_name (@$expected) {
    my $token = $tokens{$token_name};
    die "Unknown token $token_name" unless defined $token;
    my $rule = $token->[0];
    pos($$input) = $pos;
    next TOKEN unless $$input =~ $rule;

    my $matched_len = $+[0] - $-[0];
    my $matched_value = undef;

    if (defined( my $val = $token->[1] )) {
      if (ref $val eq 'CODE') {
        $matched_value = $val->();
      } else {
        $matched_value = $val;
      }
    } elsif ($#- > 0) { # Captured a value
      $matched_value = $1;
    }

    push @matches, [ $token_name, \$matched_value, $matched_len ];

    if ($token_name eq 'Safe_String') {
      if ($self->exhaustive_strings) {
        for my $len (reverse 1 .. $matched_len - 1) {
          my $value = substr($matched_value, 0, $len);
          push @matches, [ $token_name, \$value, $len ];
        }
      } elsif ($matched_value =~ /(.*) $/) {
        my $value = $1;
        push @matches, [ $token_name, \$value, $matched_len - 1 ];
      }
    }
  }

  return @matches;
}

method parse_line ($line) {
  my $rec = Marpa::R2::Recognizer->new({
      grammar => $self->line_grammar,
      ranking_method => 'rule',
#      trace_terminals => 2,
#      trace_values => 1,
#      trace_actions => 1,
  });

  for my $pos (0 .. length($line) - 1) {
    my $expected_tokens = $rec->terminals_expected;

    if (@$expected_tokens) {
      my @matching_tokens = $self->lex(\$line, $pos, $expected_tokens);
      $rec->alternative( @$_ ) for @matching_tokens;
    }

    my $ok = eval {
      $rec->earleme_complete;
      1;
    };
    if (!$ok) {
      return [ 'Junk_Line', $line ];
    }
  }

  $rec->end_input;

  return ${$rec->value};
}

method parse {
  my $rec = Marpa::R2::Recognizer->new({
      grammar => $self->stream_grammar,
      ranking_method => 'rule',
#      trace_terminals => 2,
#      trace_values => 1,
#      trace_actions => 1,
  });

  my $reader = $self->reader;

  while (defined( my $line = $reader->() )) {
#    print "Expecting: ", join(" ", @{ $rec->terminals_expected }), "\n";
    my $line_token = $self->parse_line($line);
    next if $line_token->[0] eq 'Junk_Line'; # XXX do something cooler
    unless (defined $rec->read(@$line_token)) {
      my $expected = $rec->terminals_expected;
      die "Parse error, expecting [@$expected], got $line_token->[0]";
    }
  }

  $rec->read('EOF');

  return ${$rec->value};
}

no Mouse;

package TAP::Spec::Parser::Actions;
BEGIN {
  $TAP::Spec::Parser::Actions::AUTHORITY = 'cpan:ARODLAND';
}
{
  $TAP::Spec::Parser::Actions::VERSION = '0.07_991'; # TRIAL
}

sub subrule1 {
  $_[1];
}

sub subrule2 {
  $_[2];
}

sub tokenize_TAP_Line {
  [ 'TAP_Line', $_[1] ];
}

sub tokenize_Version {
  [ 'Version', $_[1] ];
}

sub tokenize_Plan {
  [ 'Plan', $_[1] ];
}

sub tokenize_Comment {
  [ 'Comment', $_[1] ];
}

sub Testset {
  my %tmp;
  $tmp{header} = $_[1] || TAP::Spec::Header->new;
  $tmp{plan} = $_[2][0];
  $tmp{body} = $_[2][1];
  $tmp{footer} = $_[3] || TAP::Spec::Footer->new;

  TAP::Spec::TestSet->new(%tmp);
}

sub Plan_Body {
  my $plan = $_[1];
  my $body = $_[2];
  [ $plan, $body ];
}

sub Body_Plan {
  my $body = $_[1];
  my $plan = $_[2];
  [ $plan, $body ];
}

sub Header {
  my %tmp;
  $tmp{comments} = $_[1] if defined $_[1];
  $tmp{version} = $_[2] if defined $_[2];
  TAP::Spec::Header->new(%tmp);
}

# Footer          = [Comments]
sub Footer {
  my %tmp;
  $tmp{comments} = $_[1] if defined $_[1];
  TAP::Spec::Footer->new(%tmp);
}

# Body            = *(Comment / TAP-Line)
sub Body {
  shift;
  my @lines = @_;
  TAP::Spec::Body->new(lines => \@lines);
}

sub Comments {
  shift;
  my @comments = @_;
  return \@comments;
}

sub Version {
  my $version_number = $_[3];
  TAP::Spec::Version->new(version_number => $version_number);
}

sub Plan_Simple {
  my $number_of_tests = $_[1];
  TAP::Spec::Plan::Simple->new(number_of_tests => $number_of_tests);
}

sub Plan_Todo {
  my $number_of_tests = $_[1];
  my $skipped_tests = $_[5];

  TAP::Spec::Plan::Todo->new(
    number_of_tests => $number_of_tests,
    skipped_tests => $skipped_tests,
  );
}

sub Test_Numbers {
  shift;
  my @test_numbers = @_;
  \@test_numbers;
}

sub Plan_Skip_All {
  my $reason = $_[5];
  TAP::Spec::Plan::SkipAll->new(
    reason => $reason,
  );
}

sub Test_Result {
  my %tmp;
  $tmp{status} = $_[1];
  $tmp{number} = $_[2] if defined $_[2];
  $tmp{description} = $_[3] if defined $_[3];
  $tmp{directive} = $_[4][0] if defined $_[4] && defined $_[4][0];
  $tmp{reason} = $_[4][1] if defined $_[4] && defined $_[4][1];
  TAP::Spec::TestResult->new(%tmp);
}

sub Maybe_Directive_Reason {
  my $directive = $_[4];
  my $reason = $_[5];
  return [ $directive, $reason ];
}

sub Bail_Out {
  my %tmp;
  $tmp{reason} = $_[1] if defined $_[1];
  TAP::Spec::BailOut->new( %tmp );
}

sub Comment {
  my $text = $_[1];
  TAP::Spec::Comment->new( text => $text );
}

sub String {
  shift;
  my @parts = @_;
  return join "", @parts;
}

sub undef {
  undef
}

1;

__END__