cpan/Test-Harness/lib/TAP/Parser/Grammar.pm

   1 package TAP::Parser::Grammar;
   2
   3 use strict;
   4 use warnings;
   5
   6 use TAP::Parser::ResultFactory   ();
   7 use TAP::Parser::YAMLish::Reader ();
   8
   9 use base 'TAP::Object';
  10
  11 =head1 NAME
  12
  13 TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
  14
  15 =head1 VERSION
  16
  17 Version 3.42
  18
  19 =cut
  20
  21 our $VERSION = '3.42';
  22
  23 =head1 SYNOPSIS
  24
  25   use TAP::Parser::Grammar;
  26   my $grammar = $self->make_grammar({
  27     iterator => $tap_parser_iterator,
  28     parser   => $tap_parser,
  29     version  => 12,
  30   });
  31
  32   my $result = $grammar->tokenize;
  33
  34 =head1 DESCRIPTION
  35
  36 C<TAP::Parser::Grammar> tokenizes lines from a L<TAP::Parser::Iterator> and
  37 constructs L<TAP::Parser::Result> subclasses to represent the tokens.
  38
  39 Do not attempt to use this class directly.  It won't make sense.  It's mainly
  40 here to ensure that we will be able to have pluggable grammars when TAP is
  41 expanded at some future date (plus, this stuff was really cluttering the
  42 parser).
  43
  44 =head1 METHODS
  45
  46 =head2 Class Methods
  47
  48 =head3 C<new>
  49
  50   my $grammar = TAP::Parser::Grammar->new({
  51       iterator => $iterator,
  52       parser   => $parser,
  53       version  => $version,
  54   });
  55
  56 Returns L<TAP::Parser> grammar object that will parse the TAP stream from the
  57 specified iterator.  Both C<iterator> and C<parser> are required arguments.
  58 If C<version> is not set it defaults to C<12> (see L</set_version> for more
  59 details).
  60
  61 =cut
  62
  63 # new() implementation supplied by TAP::Object
  64 sub _initialize {
  65     my ( $self, $args ) = @_;
  66     $self->{iterator} = $args->{iterator};    # TODO: accessor
  67     $self->{iterator} ||= $args->{stream};    # deprecated
  68     $self->{parser} = $args->{parser};        # TODO: accessor
  69     $self->set_version( $args->{version} || 12 );
  70     return $self;
  71 }
  72
  73 my %language_for;
  74
  75 {
  76
  77     # XXX the 'not' and 'ok' might be on separate lines in VMS ...
  78     my $ok  = qr/(?:not )?ok\b/;
  79     my $num = qr/\d+/;
  80
  81     my %v12 = (
  82         version => {
  83             syntax  => qr/^TAP\s+version\s+(\d+)\s*\z/i,
  84             handler => sub {
  85                 my ( $self, $line ) = @_;
  86                 my $version = $1;
  87                 return $self->_make_version_token( $line, $version, );
  88             },
  89         },
  90         plan => {
  91             syntax  => qr/^1\.\.(\d+)\s*(.*)\z/,
  92             handler => sub {
  93                 my ( $self, $line ) = @_;
  94                 my ( $tests_planned, $tail ) = ( $1, $2 );
  95                 my $explanation = undef;
  96                 my $skip        = '';
  97
  98                 if ( $tail =~ /^todo((?:\s+\d+)+)/ ) {
  99                     my @todo = split /\s+/, _trim($1);
 100                     return $self->_make_plan_token(
 101                         $line, $tests_planned, 'TODO',
 102                         '',    \@todo
 103                     );
 104                 }
 105                 elsif ( 0 == $tests_planned ) {
 106                     $skip = 'SKIP';
 107
 108                     # If we can't match # SKIP the directive should be undef.
 109                     ($explanation) = $tail =~ /^#\s*SKIP\S*\s+(.*)/i;
 110                 }
 111                 elsif ( $tail !~ /^\s*$/ ) {
 112                     return $self->_make_unknown_token($line);
 113                 }
 114
 115                 $explanation = '' unless defined $explanation;
 116
 117                 return $self->_make_plan_token(
 118                     $line, $tests_planned, $skip,
 119                     $explanation, []
 120                 );
 121
 122             },
 123         },
 124
 125         # An optimization to handle the most common test lines without
 126         # directives.
 127         simple_test => {
 128             syntax  => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x,
 129             handler => sub {
 130                 my ( $self, $line ) = @_;
 131                 my ( $ok, $num, $desc ) = ( $1, $2, $3 );
 132
 133                 return $self->_make_test_token(
 134                     $line, $ok, $num,
 135                     $desc
 136                 );
 137             },
 138         },
 139         test => {
 140             syntax  => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
 141             handler => sub {
 142                 my ( $self, $line ) = @_;
 143                 my ( $ok, $num, $desc ) = ( $1, $2, $3 );
 144                 my ( $dir, $explanation ) = ( '', '' );
 145                 if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* )
 146                        \# \s* (SKIP|TODO) \b \s* (.*) $/ix
 147                   )
 148                 {
 149                     ( $desc, $dir, $explanation ) = ( $1, $2, $3 );
 150                 }
 151                 return $self->_make_test_token(
 152                     $line, $ok, $num, $desc,
 153                     $dir,  $explanation
 154                 );
 155             },
 156         },
 157         comment => {
 158             syntax  => qr/^#(.*)/,
 159             handler => sub {
 160                 my ( $self, $line ) = @_;
 161                 my $comment = $1;
 162                 return $self->_make_comment_token( $line, $comment );
 163             },
 164         },
 165         bailout => {
 166             syntax  => qr/^\s*Bail out!\s*(.*)/,
 167             handler => sub {
 168                 my ( $self, $line ) = @_;
 169                 my $explanation = $1;
 170                 return $self->_make_bailout_token(
 171                     $line,
 172                     $explanation
 173                 );
 174             },
 175         },
 176     );
 177
 178     my %v13 = (
 179         %v12,
 180         plan => {
 181             syntax  => qr/^1\.\.(\d+)\s*(?:\s*#\s*SKIP\b(.*))?\z/i,
 182             handler => sub {
 183                 my ( $self, $line ) = @_;
 184                 my ( $tests_planned, $explanation ) = ( $1, $2 );
 185                 my $skip
 186                   = ( 0 == $tests_planned || defined $explanation )
 187                   ? 'SKIP'
 188                   : '';
 189                 $explanation = '' unless defined $explanation;
 190                 return $self->_make_plan_token(
 191                     $line, $tests_planned, $skip,
 192                     $explanation, []
 193                 );
 194             },
 195         },
 196         yaml => {
 197             syntax  => qr/^ (\s+) (---.*) $/x,
 198             handler => sub {
 199                 my ( $self, $line ) = @_;
 200                 my ( $pad, $marker ) = ( $1, $2 );
 201                 return $self->_make_yaml_token( $pad, $marker );
 202             },
 203         },
 204         pragma => {
 205             syntax =>
 206               qr/^ pragma \s+ ( [-+] \w+ \s* (?: , \s* [-+] \w+ \s* )* ) $/x,
 207             handler => sub {
 208                 my ( $self, $line ) = @_;
 209                 my $pragmas = $1;
 210                 return $self->_make_pragma_token( $line, $pragmas );
 211             },
 212         },
 213     );
 214
 215     %language_for = (
 216         '12' => {
 217             tokens => \%v12,
 218         },
 219         '13' => {
 220             tokens => \%v13,
 221             setup  => sub {
 222                 shift->{iterator}->handle_unicode;
 223             },
 224         },
 225     );
 226 }
 227
 228 ##############################################################################
 229
 230 =head2 Instance Methods
 231
 232 =head3 C<set_version>
 233
 234   $grammar->set_version(13);
 235
 236 Tell the grammar which TAP syntax version to support. The lowest
 237 supported version is 12. Although 'TAP version' isn't valid version 12
 238 syntax it is accepted so that higher version numbers may be parsed.
 239
 240 =cut
 241
 242 sub set_version {
 243     my $self    = shift;
 244     my $version = shift;
 245
 246     if ( my $language = $language_for{$version} ) {
 247         $self->{version} = $version;
 248         $self->{tokens}  = $language->{tokens};
 249
 250         if ( my $setup = $language->{setup} ) {
 251             $self->$setup();
 252         }
 253
 254         $self->_order_tokens;
 255     }
 256     else {
 257         require Carp;
 258         Carp::croak("Unsupported syntax version: $version");
 259     }
 260 }
 261
 262 # Optimization to put the most frequent tokens first.
 263 sub _order_tokens {
 264     my $self = shift;
 265
 266     my %copy = %{ $self->{tokens} };
 267     my @ordered_tokens = grep {defined}
 268       map { delete $copy{$_} } qw( simple_test test comment plan );
 269     push @ordered_tokens, values %copy;
 270
 271     $self->{ordered_tokens} = \@ordered_tokens;
 272 }
 273
 274 ##############################################################################
 275
 276 =head3 C<tokenize>
 277
 278   my $token = $grammar->tokenize;
 279
 280 This method will return a L<TAP::Parser::Result> object representing the
 281 current line of TAP.
 282
 283 =cut
 284
 285 sub tokenize {
 286     my $self = shift;
 287
 288     my $line = $self->{iterator}->next;
 289     unless ( defined $line ) {
 290         delete $self->{parser};    # break circular ref
 291         return;
 292     }
 293
 294     my $token;
 295
 296     for my $token_data ( @{ $self->{ordered_tokens} } ) {
 297         if ( $line =~ $token_data->{syntax} ) {
 298             my $handler = $token_data->{handler};
 299             $token = $self->$handler($line);
 300             last;
 301         }
 302     }
 303
 304     $token = $self->_make_unknown_token($line) unless $token;
 305
 306     return $self->{parser}->make_result($token);
 307 }
 308
 309 ##############################################################################
 310
 311 =head3 C<token_types>
 312
 313   my @types = $grammar->token_types;
 314
 315 Returns the different types of tokens which this grammar can parse.
 316
 317 =cut
 318
 319 sub token_types {
 320     my $self = shift;
 321     return keys %{ $self->{tokens} };
 322 }
 323
 324 ##############################################################################
 325
 326 =head3 C<syntax_for>
 327
 328   my $syntax = $grammar->syntax_for($token_type);
 329
 330 Returns a pre-compiled regular expression which will match a chunk of TAP
 331 corresponding to the token type.  For example (not that you should really pay
 332 attention to this, C<< $grammar->syntax_for('comment') >> will return
 333 C<< qr/^#(.*)/ >>.
 334
 335 =cut
 336
 337 sub syntax_for {
 338     my ( $self, $type ) = @_;
 339     return $self->{tokens}->{$type}->{syntax};
 340 }
 341
 342 ##############################################################################
 343
 344 =head3 C<handler_for>
 345
 346   my $handler = $grammar->handler_for($token_type);
 347
 348 Returns a code reference which, when passed an appropriate line of TAP,
 349 returns the lexed token corresponding to that line.  As a result, the basic
 350 TAP parsing loop looks similar to the following:
 351
 352  my @tokens;
 353  my $grammar = TAP::Grammar->new;
 354  LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) {
 355      for my $type ( $grammar->token_types ) {
 356          my $syntax  = $grammar->syntax_for($type);
 357          if ( $line =~ $syntax ) {
 358              my $handler = $grammar->handler_for($type);
 359              push @tokens => $grammar->$handler($line);
 360              next LINE;
 361          }
 362      }
 363      push @tokens => $grammar->_make_unknown_token($line);
 364  }
 365
 366 =cut
 367
 368 sub handler_for {
 369     my ( $self, $type ) = @_;
 370     return $self->{tokens}->{$type}->{handler};
 371 }
 372
 373 sub _make_version_token {
 374     my ( $self, $line, $version ) = @_;
 375     return {
 376         type    => 'version',
 377         raw     => $line,
 378         version => $version,
 379     };
 380 }
 381
 382 sub _make_plan_token {
 383     my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_;
 384
 385     if (   $directive eq 'SKIP'
 386         && 0 != $tests_planned
 387         && $self->{version} < 13 )
 388     {
 389         warn
 390           "Specified SKIP directive in plan but more than 0 tests ($line)\n";
 391     }
 392
 393     return {
 394         type          => 'plan',
 395         raw           => $line,
 396         tests_planned => $tests_planned,
 397         directive     => $directive,
 398         explanation   => _trim($explanation),
 399         todo_list     => $todo,
 400     };
 401 }
 402
 403 sub _make_test_token {
 404     my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
 405     return {
 406         ok          => $ok,
 407
 408         # forcing this to be an integer (and not a string) reduces memory
 409         # consumption. RT #84939
 410         test_num    => ( defined $num ? 0 + $num : undef ),
 411         description => _trim($desc),
 412         directive   => ( defined $dir ? uc $dir : '' ),
 413         explanation => _trim($explanation),
 414         raw         => $line,
 415         type        => 'test',
 416     };
 417 }
 418
 419 sub _make_unknown_token {
 420     my ( $self, $line ) = @_;
 421     return {
 422         raw  => $line,
 423         type => 'unknown',
 424     };
 425 }
 426
 427 sub _make_comment_token {
 428     my ( $self, $line, $comment ) = @_;
 429     return {
 430         type    => 'comment',
 431         raw     => $line,
 432         comment => _trim($comment)
 433     };
 434 }
 435
 436 sub _make_bailout_token {
 437     my ( $self, $line, $explanation ) = @_;
 438     return {
 439         type    => 'bailout',
 440         raw     => $line,
 441         bailout => _trim($explanation)
 442     };
 443 }
 444
 445 sub _make_yaml_token {
 446     my ( $self, $pad, $marker ) = @_;
 447
 448     my $yaml = TAP::Parser::YAMLish::Reader->new;
 449
 450     my $iterator = $self->{iterator};
 451
 452     # Construct a reader that reads from our input stripping leading
 453     # spaces from each line.
 454     my $leader = length($pad);
 455     my $strip  = qr{ ^ (\s{$leader}) (.*) $ }x;
 456     my @extra  = ($marker);
 457     my $reader = sub {
 458         return shift @extra if @extra;
 459         my $line = $iterator->next;
 460         return $2 if $line =~ $strip;
 461         return;
 462     };
 463
 464     my $data = $yaml->read($reader);
 465
 466     # Reconstitute input. This is convoluted. Maybe we should just
 467     # record it on the way in...
 468     chomp( my $raw = $yaml->get_raw );
 469     $raw =~ s/^/$pad/mg;
 470
 471     return {
 472         type => 'yaml',
 473         raw  => $raw,
 474         data => $data
 475     };
 476 }
 477
 478 sub _make_pragma_token {
 479     my ( $self, $line, $pragmas ) = @_;
 480     return {
 481         type    => 'pragma',
 482         raw     => $line,
 483         pragmas => [ split /\s*,\s*/, _trim($pragmas) ],
 484     };
 485 }
 486
 487 sub _trim {
 488     my $data = shift;
 489
 490     return '' unless defined $data;
 491
 492     $data =~ s/^\s+//;
 493     $data =~ s/\s+$//;
 494     return $data;
 495 }
 496
 497 1;
 498
 499 =head1 TAP GRAMMAR
 500
 501 B<NOTE:>  This grammar is slightly out of date.  There's still some discussion
 502 about it and a new one will be provided when we have things better defined.
 503
 504 The L<TAP::Parser> does not use a formal grammar because TAP is essentially a
 505 stream-based protocol.  In fact, it's quite legal to have an infinite stream.
 506 For the same reason that we don't apply regexes to streams, we're not using a
 507 formal grammar here.  Instead, we parse the TAP in lines.
 508
 509 For purposes for forward compatibility, any result which does not match the
 510 following grammar is currently referred to as
 511 L<TAP::Parser::Result::Unknown>.  It is I<not> a parse error.
 512
 513 A formal grammar would look similar to the following:
 514
 515  (*
 516      For the time being, I'm cheating on the EBNF by allowing
 517      certain terms to be defined by POSIX character classes by
 518      using the following syntax:
 519
 520        digit ::= [:digit:]
 521
 522      As far as I am aware, that's not valid EBNF.  Sue me.  I
 523      didn't know how to write "char" otherwise (Unicode issues).
 524      Suggestions welcome.
 525  *)
 526
 527  tap            ::= version? { comment | unknown } leading_plan lines
 528                     |
 529                     lines trailing_plan {comment}
 530
 531  version        ::= 'TAP version ' positiveInteger {positiveInteger} "\n"
 532
 533  leading_plan   ::= plan skip_directive? "\n"
 534
 535  trailing_plan  ::= plan "\n"
 536
 537  plan           ::= '1..' nonNegativeInteger
 538
 539  lines          ::= line {line}
 540
 541  line           ::= (comment | test | unknown | bailout ) "\n"
 542
 543  test           ::= status positiveInteger? description? directive?
 544
 545  status         ::= 'not '? 'ok '
 546
 547  description    ::= (character - (digit | '#')) {character - '#'}
 548
 549  directive      ::= todo_directive | skip_directive
 550
 551  todo_directive ::= hash_mark 'TODO' ' ' {character}
 552
 553  skip_directive ::= hash_mark 'SKIP' ' ' {character}
 554
 555  comment        ::= hash_mark {character}
 556
 557  hash_mark      ::= '#' {' '}
 558
 559  bailout        ::= 'Bail out!' {character}
 560
 561  unknown        ::= { (character - "\n") }
 562
 563  (* POSIX character classes and other terminals *)
 564
 565  digit              ::= [:digit:]
 566  character          ::= ([:print:] - "\n")
 567  positiveInteger    ::= ( digit - '0' ) {digit}
 568  nonNegativeInteger ::= digit {digit}
 569
 570 =head1 SUBCLASSING
 571
 572 Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
 573
 574 If you I<really> want to subclass L<TAP::Parser>'s grammar the best thing to
 575 do is read through the code.  There's no easy way of summarizing it here.
 576
 577 =head1 SEE ALSO
 578
 579 L<TAP::Object>,
 580 L<TAP::Parser>,
 581 L<TAP::Parser::Iterator>,
 582 L<TAP::Parser::Result>,
 583
 584 =cut