ext/Test/Harness/t/parse.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4
   5 BEGIN {
   6     if ( $ENV{PERL_CORE} ) {
   7         chdir 't';
   8         @INC = ( '../lib', '../ext/Test/Harness/t/lib' );
   9     }
  10     else {
  11         use lib 't/lib';
  12     }
  13 }
  14
  15 use Test::More tests => 282;
  16 use IO::c55Capture;
  17
  18 use File::Spec;
  19
  20 use TAP::Parser;
  21 use TAP::Parser::IteratorFactory;
  22
  23 sub _get_results {
  24     my $parser = shift;
  25     my @results;
  26     while ( defined( my $result = $parser->next ) ) {
  27         push @results => $result;
  28     }
  29     return @results;
  30 }
  31
  32 my ( $PARSER, $PLAN, $PRAGMA, $TEST, $COMMENT, $BAILOUT, $UNKNOWN, $YAML, $VERSION ) = qw(
  33   TAP::Parser
  34   TAP::Parser::Result::Plan
  35   TAP::Parser::Result::Pragma
  36   TAP::Parser::Result::Test
  37   TAP::Parser::Result::Comment
  38   TAP::Parser::Result::Bailout
  39   TAP::Parser::Result::Unknown
  40   TAP::Parser::Result::YAML
  41   TAP::Parser::Result::Version
  42 );
  43
  44 my $factory = TAP::Parser::IteratorFactory->new;
  45
  46 my $tap = <<'END_TAP';
  47 TAP version 13
  48 1..7
  49 ok 1 - input file opened
  50 ... this is junk
  51 not ok first line of the input valid # todo some data
  52 # this is a comment
  53 ok 3 - read the rest of the file
  54 not ok 4 - this is a real failure
  55   --- YAML!
  56   ...
  57 ok 5 # skip we have no description
  58 ok 6 - you shall not pass! # TODO should have failed
  59 not ok 7 - Gandalf wins.  Game over.  # TODO 'bout time!
  60 END_TAP
  61
  62 can_ok $PARSER, 'new';
  63 my $parser = $PARSER->new( { tap => $tap } );
  64 isa_ok $parser, $PARSER, '... and the object it returns';
  65
  66 ok $ENV{TAP_VERSION}, 'TAP_VERSION env variable should be set';
  67
  68 # results() is sane?
  69
  70 my @results = _get_results($parser);
  71 is scalar @results, 12, '... and there should be one for each line';
  72
  73 my $version = shift @results;
  74 isa_ok $version, $VERSION;
  75 is $version->version, '13', '... and the version should be 13';
  76
  77 # check the test plan
  78
  79 my $result = shift @results;
  80 isa_ok $result, $PLAN;
  81 can_ok $result, 'type';
  82 is $result->type, 'plan', '... and it should report the correct type';
  83 ok $result->is_plan, '... and it should identify itself as a plan';
  84 is $result->plan, '1..7', '... and identify the plan';
  85 ok !$result->directive,   '... and this plan should not have a directive';
  86 ok !$result->explanation, '... or a directive explanation';
  87 is $result->as_string, '1..7',
  88   '... and have the correct string representation';
  89 is $result->raw, '1..7', '... and raw() should return the original line';
  90
  91 # a normal, passing test
  92
  93 my $test = shift @results;
  94 isa_ok $test, $TEST;
  95 is $test->type, 'test', '... and it should report the correct type';
  96 ok $test->is_test, '... and it should identify itself as a test';
  97 is $test->ok,      'ok', '... and it should have the correct ok()';
  98 ok $test->is_ok,   '... and the correct boolean version of is_ok()';
  99 ok $test->is_actual_ok,
 100   '... and the correct boolean version of is_actual_ok()';
 101 is $test->number, 1, '... and have the correct test number';
 102 is $test->description, '- input file opened',
 103   '... and the correct description';
 104 ok !$test->directive,   '... and not have a directive';
 105 ok !$test->explanation, '... or a directive explanation';
 106 ok !$test->has_skip,    '... and it is not a SKIPped test';
 107 ok !$test->has_todo,    '... nor a TODO test';
 108 is $test->as_string, 'ok 1 - input file opened',
 109   '... and its string representation should be correct';
 110 is $test->raw, 'ok 1 - input file opened',
 111   '... and raw() should return the original line';
 112
 113 # junk lines should be preserved
 114
 115 my $unknown = shift @results;
 116 isa_ok $unknown, $UNKNOWN;
 117 is $unknown->type, 'unknown', '... and it should report the correct type';
 118 ok $unknown->is_unknown, '... and it should identify itself as unknown';
 119 is $unknown->as_string,  '... this is junk',
 120   '... and its string representation should be returned verbatim';
 121 is $unknown->raw, '... this is junk',
 122   '... and raw() should return the original line';
 123
 124 # a failing test, which also happens to have a directive
 125
 126 my $failed = shift @results;
 127 isa_ok $failed, $TEST;
 128 is $failed->type, 'test', '... and it should report the correct type';
 129 ok $failed->is_test, '... and it should identify itself as a test';
 130 is $failed->ok,      'not ok', '... and it should have the correct ok()';
 131 ok $failed->is_ok,   '... and TODO tests should always pass';
 132 ok !$failed->is_actual_ok,
 133   '... and the correct boolean version of is_actual_ok ()';
 134 is $failed->number, 2, '... and have the correct failed number';
 135 is $failed->description, 'first line of the input valid',
 136   '... and the correct description';
 137 is $failed->directive, 'TODO', '... and should have the correct directive';
 138 is $failed->explanation, 'some data',
 139   '... and the correct directive explanation';
 140 ok !$failed->has_skip, '... and it is not a SKIPped failed';
 141 ok $failed->has_todo, '... but it is a TODO succeeded';
 142 is $failed->as_string,
 143   'not ok 2 first line of the input valid # TODO some data',
 144   '... and its string representation should be correct';
 145 is $failed->raw, 'not ok first line of the input valid # todo some data',
 146   '... and raw() should return the original line';
 147
 148 # comments
 149
 150 my $comment = shift @results;
 151 isa_ok $comment, $COMMENT;
 152 is $comment->type, 'comment', '... and it should report the correct type';
 153 ok $comment->is_comment, '... and it should identify itself as a comment';
 154 is $comment->comment,    'this is a comment',
 155   '... and you should be able to fetch the comment';
 156 is $comment->as_string, '# this is a comment',
 157   '... and have the correct string representation';
 158 is $comment->raw, '# this is a comment',
 159   '... and raw() should return the original line';
 160
 161 # another normal, passing test
 162
 163 $test = shift @results;
 164 isa_ok $test, $TEST;
 165 is $test->type, 'test', '... and it should report the correct type';
 166 ok $test->is_test, '... and it should identify itself as a test';
 167 is $test->ok,      'ok', '... and it should have the correct ok()';
 168 ok $test->is_ok,   '... and the correct boolean version of is_ok()';
 169 ok $test->is_actual_ok,
 170   '... and the correct boolean version of is_actual_ok()';
 171 is $test->number, 3, '... and have the correct test number';
 172 is $test->description, '- read the rest of the file',
 173   '... and the correct description';
 174 ok !$test->directive,   '... and not have a directive';
 175 ok !$test->explanation, '... or a directive explanation';
 176 ok !$test->has_skip,    '... and it is not a SKIPped test';
 177 ok !$test->has_todo,    '... nor a TODO test';
 178 is $test->as_string, 'ok 3 - read the rest of the file',
 179   '... and its string representation should be correct';
 180 is $test->raw, 'ok 3 - read the rest of the file',
 181   '... and raw() should return the original line';
 182
 183 # a failing test
 184
 185 $failed = shift @results;
 186 isa_ok $failed, $TEST;
 187 is $failed->type, 'test', '... and it should report the correct type';
 188 ok $failed->is_test, '... and it should identify itself as a test';
 189 is $failed->ok, 'not ok', '... and it should have the correct ok()';
 190 ok !$failed->is_ok, '... and the tests should not have passed';
 191 ok !$failed->is_actual_ok,
 192   '... and the correct boolean version of is_actual_ok ()';
 193 is $failed->number, 4, '... and have the correct failed number';
 194 is $failed->description, '- this is a real failure',
 195   '... and the correct description';
 196 ok !$failed->directive,   '... and should have no directive';
 197 ok !$failed->explanation, '... and no directive explanation';
 198 ok !$failed->has_skip,    '... and it is not a SKIPped failed';
 199 ok !$failed->has_todo,    '... and not a TODO test';
 200 is $failed->as_string, 'not ok 4 - this is a real failure',
 201   '... and its string representation should be correct';
 202 is $failed->raw, 'not ok 4 - this is a real failure',
 203   '... and raw() should return the original line';
 204
 205 # Some YAML
 206 my $yaml = shift @results;
 207 isa_ok $yaml, $YAML;
 208 is $yaml->type, 'yaml', '... and it should report the correct type';
 209 ok $yaml->is_yaml, '... and it should identify itself as yaml';
 210 is_deeply $yaml->data, 'YAML!', '... and data should be correct';
 211
 212 # ok 5 # skip we have no description
 213 # skipped test
 214
 215 $test = shift @results;
 216 isa_ok $test, $TEST;
 217 is $test->type, 'test', '... and it should report the correct type';
 218 ok $test->is_test, '... and it should identify itself as a test';
 219 is $test->ok,      'ok', '... and it should have the correct ok()';
 220 ok $test->is_ok,   '... and the correct boolean version of is_ok()';
 221 ok $test->is_actual_ok,
 222   '... and the correct boolean version of is_actual_ok()';
 223 is $test->number, 5, '... and have the correct test number';
 224 ok !$test->description, '... and skipped tests have no description';
 225 is $test->directive, 'SKIP', '... and the correct directive';
 226 is $test->explanation, 'we have no description',
 227   '... but we should have an explanation';
 228 ok $test->has_skip, '... and it is a SKIPped test';
 229 ok !$test->has_todo, '... but not a TODO test';
 230 is $test->as_string, 'ok 5 # SKIP we have no description',
 231   '... and its string representation should be correct';
 232 is $test->raw, 'ok 5 # skip we have no description',
 233   '... and raw() should return the original line';
 234
 235 # a failing test, which also happens to have a directive
 236 # ok 6 - you shall not pass! # TODO should have failed
 237
 238 my $bonus = shift @results;
 239 isa_ok $bonus, $TEST;
 240 can_ok $bonus, 'todo_passed';
 241 is $bonus->type, 'test', 'TODO tests should parse correctly';
 242 ok $bonus->is_test, '... and it should identify itself as a test';
 243 is $bonus->ok,      'ok', '... and it should have the correct ok()';
 244 ok $bonus->is_ok,   '... and TODO tests should not always pass';
 245 ok $bonus->is_actual_ok,
 246   '... and the correct boolean version of is_actual_ok ()';
 247 is $bonus->number, 6, '... and have the correct failed number';
 248 is $bonus->description, '- you shall not pass!',
 249   '... and the correct description';
 250 is $bonus->directive, 'TODO', '... and should have the correct directive';
 251 is $bonus->explanation, 'should have failed',
 252   '... and the correct directive explanation';
 253 ok !$bonus->has_skip, '... and it is not a SKIPped failed';
 254 ok $bonus->has_todo,  '... but it is a TODO succeeded';
 255 is $bonus->as_string, 'ok 6 - you shall not pass! # TODO should have failed',
 256   '... and its string representation should be correct';
 257 is $bonus->raw, 'ok 6 - you shall not pass! # TODO should have failed',
 258   '... and raw() should return the original line';
 259 ok $bonus->todo_passed,
 260   '... todo_bonus() should pass for TODO tests which unexpectedly succeed';
 261
 262 # not ok 7 - Gandalf wins.  Game over.  # TODO 'bout time!
 263
 264 my $passed = shift @results;
 265 isa_ok $passed, $TEST;
 266 can_ok $passed, 'todo_passed';
 267 is $passed->type, 'test', 'TODO tests should parse correctly';
 268 ok $passed->is_test, '... and it should identify itself as a test';
 269 is $passed->ok,      'not ok', '... and it should have the correct ok()';
 270 ok $passed->is_ok,   '... and TODO tests should always pass';
 271 ok !$passed->is_actual_ok,
 272   '... and the correct boolean version of is_actual_ok ()';
 273 is $passed->number, 7, '... and have the correct passed number';
 274 is $passed->description, '- Gandalf wins.  Game over.',
 275   '... and the correct description';
 276 is $passed->directive, 'TODO', '... and should have the correct directive';
 277 is $passed->explanation, "'bout time!",
 278   '... and the correct directive explanation';
 279 ok !$passed->has_skip, '... and it is not a SKIPped passed';
 280 ok $passed->has_todo, '... but it is a TODO succeeded';
 281 is $passed->as_string,
 282   "not ok 7 - Gandalf wins.  Game over. # TODO 'bout time!",
 283   '... and its string representation should be correct';
 284 is $passed->raw, "not ok 7 - Gandalf wins.  Game over.  # TODO 'bout time!",
 285   '... and raw() should return the original line';
 286 ok !$passed->todo_passed,
 287   '... todo_passed() should not pass for TODO tests which failed';
 288
 289 # test parse results
 290
 291 can_ok $parser, 'passed';
 292 is $parser->passed, 6,
 293   '... and we should have the correct number of passed tests';
 294 is_deeply [ $parser->passed ], [ 1, 2, 3, 5, 6, 7 ],
 295   '... and get a list of the passed tests';
 296
 297 can_ok $parser, 'failed';
 298 is $parser->failed, 1, '... and the correct number of failed tests';
 299 is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests';
 300
 301 can_ok $parser, 'actual_passed';
 302 is $parser->actual_passed, 4,
 303   '... and we should have the correct number of actually passed tests';
 304 is_deeply [ $parser->actual_passed ], [ 1, 3, 5, 6 ],
 305   '... and get a list of the actually passed tests';
 306
 307 can_ok $parser, 'actual_failed';
 308 is $parser->actual_failed, 3,
 309   '... and the correct number of actually failed tests';
 310 is_deeply [ $parser->actual_failed ], [ 2, 4, 7 ],
 311   '... or get a list of the actually failed tests';
 312
 313 can_ok $parser, 'todo';
 314 is $parser->todo, 3,
 315   '... and we should have the correct number of TODO tests';
 316 is_deeply [ $parser->todo ], [ 2, 6, 7 ],
 317   '... and get a list of the TODO tests';
 318
 319 can_ok $parser, 'skipped';
 320 is $parser->skipped, 1,
 321   '... and we should have the correct number of skipped tests';
 322 is_deeply [ $parser->skipped ], [5],
 323   '... and get a list of the skipped tests';
 324
 325 # check the plan
 326
 327 can_ok $parser, 'plan';
 328 is $parser->plan,          '1..7', '... and we should have the correct plan';
 329 is $parser->tests_planned, 7,      '... and the correct number of tests';
 330
 331 # "Unexpectedly succeeded"
 332 can_ok $parser, 'todo_passed';
 333 is scalar $parser->todo_passed, 1,
 334   '... and it should report the number of tests which unexpectedly succeeded';
 335 is_deeply [ $parser->todo_passed ], [6],
 336   '... or *which* tests unexpectedly succeeded';
 337
 338 #
 339 # Bug report from Torsten Schoenfeld
 340 # Makes sure parser can handle blank lines
 341 #
 342
 343 $tap = <<'END_TAP';
 344 1..2
 345 ok 1 - input file opened
 346
 347
 348 ok 2 - read the rest of the file
 349 END_TAP
 350
 351 my $aref = [ split /\n/ => $tap ];
 352
 353 can_ok $PARSER, 'new';
 354 $parser = $PARSER->new( { stream => $factory->make_iterator($aref) } );
 355 isa_ok $parser, $PARSER, '... and calling it should succeed';
 356
 357 # results() is sane?
 358
 359 ok @results = _get_results($parser), 'The parser should return results';
 360 is scalar @results, 5, '... and there should be one for each line';
 361
 362 # check the test plan
 363
 364 $result = shift @results;
 365 isa_ok $result, $PLAN;
 366 can_ok $result, 'type';
 367 is $result->type, 'plan', '... and it should report the correct type';
 368 ok $result->is_plan,   '... and it should identify itself as a plan';
 369 is $result->plan,      '1..2', '... and identify the plan';
 370 is $result->as_string, '1..2',
 371   '... and have the correct string representation';
 372 is $result->raw, '1..2', '... and raw() should return the original line';
 373
 374 # a normal, passing test
 375
 376 $test = shift @results;
 377 isa_ok $test, $TEST;
 378 is $test->type, 'test', '... and it should report the correct type';
 379 ok $test->is_test, '... and it should identify itself as a test';
 380 is $test->ok,      'ok', '... and it should have the correct ok()';
 381 ok $test->is_ok,   '... and the correct boolean version of is_ok()';
 382 ok $test->is_actual_ok,
 383   '... and the correct boolean version of is_actual_ok()';
 384 is $test->number, 1, '... and have the correct test number';
 385 is $test->description, '- input file opened',
 386   '... and the correct description';
 387 ok !$test->directive,   '... and not have a directive';
 388 ok !$test->explanation, '... or a directive explanation';
 389 ok !$test->has_skip,    '... and it is not a SKIPped test';
 390 ok !$test->has_todo,    '... nor a TODO test';
 391 is $test->as_string, 'ok 1 - input file opened',
 392   '... and its string representation should be correct';
 393 is $test->raw, 'ok 1 - input file opened',
 394   '... and raw() should return the original line';
 395
 396 # junk lines should be preserved
 397
 398 $unknown = shift @results;
 399 isa_ok $unknown, $UNKNOWN;
 400 is $unknown->type, 'unknown', '... and it should report the correct type';
 401 ok $unknown->is_unknown, '... and it should identify itself as unknown';
 402 is $unknown->as_string,  '',
 403   '... and its string representation should be returned verbatim';
 404 is $unknown->raw, '', '... and raw() should return the original line';
 405
 406 # ... and the second empty line
 407
 408 $unknown = shift @results;
 409 isa_ok $unknown, $UNKNOWN;
 410 is $unknown->type, 'unknown', '... and it should report the correct type';
 411 ok $unknown->is_unknown, '... and it should identify itself as unknown';
 412 is $unknown->as_string,  '',
 413   '... and its string representation should be returned verbatim';
 414 is $unknown->raw, '', '... and raw() should return the original line';
 415
 416 # a passing test
 417
 418 $test = shift @results;
 419 isa_ok $test, $TEST;
 420 is $test->type, 'test', '... and it should report the correct type';
 421 ok $test->is_test, '... and it should identify itself as a test';
 422 is $test->ok,      'ok', '... and it should have the correct ok()';
 423 ok $test->is_ok,   '... and the correct boolean version of is_ok()';
 424 ok $test->is_actual_ok,
 425   '... and the correct boolean version of is_actual_ok()';
 426 is $test->number, 2, '... and have the correct test number';
 427 is $test->description, '- read the rest of the file',
 428   '... and the correct description';
 429 ok !$test->directive,   '... and not have a directive';
 430 ok !$test->explanation, '... or a directive explanation';
 431 ok !$test->has_skip,    '... and it is not a SKIPped test';
 432 ok !$test->has_todo,    '... nor a TODO test';
 433 is $test->as_string, 'ok 2 - read the rest of the file',
 434   '... and its string representation should be correct';
 435 is $test->raw, 'ok 2 - read the rest of the file',
 436   '... and raw() should return the original line';
 437
 438 is scalar $parser->passed, 2,
 439   'Empty junk lines should not affect the correct number of tests passed';
 440
 441 {
 442
 443     # set a spool to write to
 444     tie local *SPOOL, 'IO::c55Capture';
 445
 446     my $tap = <<'END_TAP';
 447 TAP version 13
 448 1..7
 449 ok 1 - input file opened
 450 ... this is junk
 451 not ok first line of the input valid # todo some data
 452 # this is a comment
 453 ok 3 - read the rest of the file
 454 not ok 4 - this is a real failure
 455   --- YAML!
 456   ...
 457 ok 5 # skip we have no description
 458 ok 6 - you shall not pass! # TODO should have failed
 459 not ok 7 - Gandalf wins.  Game over.  # TODO 'bout time!
 460 END_TAP
 461
 462     {
 463         my $parser = $PARSER->new(
 464             {   tap   => $tap,
 465                 spool => \*SPOOL,
 466             }
 467         );
 468
 469         _get_results($parser);
 470
 471         my @spooled = tied(*SPOOL)->dump();
 472
 473         is @spooled, 24, 'coverage testing for spool attribute of parser';
 474         is join( '', @spooled ), $tap, "spooled tap matches";
 475     }
 476
 477     {
 478         my $parser = $PARSER->new(
 479             {   tap   => $tap,
 480                 spool => \*SPOOL,
 481             }
 482         );
 483
 484         $parser->callback( 'ALL', sub { } );
 485
 486         _get_results($parser);
 487
 488         my @spooled = tied(*SPOOL)->dump();
 489
 490         is @spooled, 24, 'coverage testing for spool attribute of parser';
 491         is join( '', @spooled ), $tap, "spooled tap matches";
 492     }
 493 }
 494
 495 {
 496
 497     # _initialize coverage
 498
 499     my $x = bless [], 'kjsfhkjsdhf';
 500
 501     my @die;
 502
 503     eval {
 504         local $SIG{__DIE__} = sub { push @die, @_ };
 505
 506         $PARSER->new();
 507     };
 508
 509     is @die, 1, 'coverage testing for _initialize';
 510
 511     like pop @die, qr/PANIC:\s+could not determine stream at/,
 512       '...and it failed as expected';
 513
 514     @die = ();
 515
 516     eval {
 517         local $SIG{__DIE__} = sub { push @die, @_ };
 518
 519         $PARSER->new(
 520             {   stream => 'stream',
 521                 tap    => 'tap',
 522                 source => 'source',    # only one of these is allowed
 523             }
 524         );
 525     };
 526
 527     is @die, 1, 'coverage testing for _initialize';
 528
 529     like pop @die,
 530       qr/You may only choose one of 'exec', 'stream', 'tap' or 'source'/,
 531       '...and it failed as expected';
 532 }
 533
 534 {
 535
 536     # coverage of todo_failed
 537
 538     my $tap = <<'END_TAP';
 539 TAP version 13
 540 1..7
 541 ok 1 - input file opened
 542 ... this is junk
 543 not ok first line of the input valid # todo some data
 544 # this is a comment
 545 ok 3 - read the rest of the file
 546 not ok 4 - this is a real failure
 547   --- YAML!
 548   ...
 549 ok 5 # skip we have no description
 550 ok 6 - you shall not pass! # TODO should have failed
 551 not ok 7 - Gandalf wins.  Game over.  # TODO 'bout time!
 552 END_TAP
 553
 554     my $parser = $PARSER->new( { tap => $tap } );
 555
 556     _get_results($parser);
 557
 558     my @warn;
 559
 560     eval {
 561         local $SIG{__WARN__} = sub { push @warn, @_ };
 562
 563         $parser->todo_failed;
 564     };
 565
 566     is @warn, 1, 'coverage testing of todo_failed';
 567
 568     like pop @warn,
 569       qr/"todo_failed" is deprecated.  Please use "todo_passed".  See the docs[.]/,
 570       '..and failed as expected'
 571 }
 572
 573 {
 574
 575     # coverage testing for T::P::_initialize
 576
 577     # coverage of the source argument paths
 578
 579     # ref argument to source
 580
 581     my $parser = TAP::Parser->new( { source => [ split /$/, $tap ] } );
 582
 583     isa_ok $parser, 'TAP::Parser';
 584
 585     isa_ok $parser->_stream, 'TAP::Parser::Iterator::Array';
 586
 587     # uncategorisable argument to source
 588     my @die;
 589
 590     eval {
 591         local $SIG{__DIE__} = sub { push @die, @_ };
 592
 593         $parser = TAP::Parser->new( { source => 'nosuchfile' } );
 594     };
 595
 596     is @die, 1, 'uncategorisable source';
 597
 598     like pop @die, qr/Cannot determine source for nosuchfile/,
 599       '... and we died as expected';
 600 }
 601
 602 {
 603
 604     # coverage test of perl source with switches
 605
 606     my $parser = TAP::Parser->new(
 607         {   source => File::Spec->catfile(
 608                 (   $ENV{PERL_CORE}
 609                     ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
 610                     : ()
 611                 ),
 612                 't',
 613                 'sample-tests',
 614                 'simple'
 615             ),
 616         }
 617     );
 618
 619     isa_ok $parser, 'TAP::Parser';
 620
 621     isa_ok $parser->_stream, 'TAP::Parser::Iterator::Process';
 622
 623     # Workaround for Mac OS X problem wrt closing the iterator without
 624     # reading from it.
 625     $parser->next;
 626 }
 627
 628 {
 629
 630     # coverage testing for TAP::Parser::has_problems
 631
 632     # we're going to need to test lots of fragments of tap
 633     # to cover all the different boolean tests
 634
 635     # currently covered are no problems and failed, so let's next test
 636     # todo_passed
 637
 638     my $tap = <<'END_TAP';
 639 TAP version 13
 640 1..2
 641 ok 1 - input file opened
 642 ok 2 - Gandalf wins.  Game over.  # TODO 'bout time!
 643 END_TAP
 644
 645     my $parser = TAP::Parser->new( { tap => $tap } );
 646
 647     _get_results($parser);
 648
 649     ok !$parser->failed, 'parser didnt fail';
 650     ok $parser->todo_passed, '... and todo_passed is true';
 651
 652     ok !$parser->has_problems, '... and has_problems is false';
 653
 654     # now parse_errors
 655
 656     $tap = <<'END_TAP';
 657 TAP version 13
 658 1..2
 659 SMACK
 660 END_TAP
 661
 662     $parser = TAP::Parser->new( { tap => $tap } );
 663
 664     _get_results($parser);
 665
 666     ok !$parser->failed,      'parser didnt fail';
 667     ok !$parser->todo_passed, '... and todo_passed is false';
 668     ok $parser->parse_errors, '... and parse_errors is true';
 669
 670     ok $parser->has_problems, '... and has_problems';
 671
 672     # Now wait and exit are hard to do in an OS platform-independent way, so
 673     # we won't even bother
 674
 675     $tap = <<'END_TAP';
 676 TAP version 13
 677 1..2
 678 ok 1 - input file opened
 679 ok 2 - Gandalf wins
 680 END_TAP
 681
 682     $parser = TAP::Parser->new( { tap => $tap } );
 683
 684     _get_results($parser);
 685
 686     $parser->wait(1);
 687
 688     ok !$parser->failed,       'parser didnt fail';
 689     ok !$parser->todo_passed,  '... and todo_passed is false';
 690     ok !$parser->parse_errors, '... and parse_errors is false';
 691
 692     ok $parser->wait, '... and wait is set';
 693
 694     ok $parser->has_problems, '... and has_problems';
 695
 696     # and use the same for exit
 697
 698     $parser->wait(0);
 699     $parser->exit(1);
 700
 701     ok !$parser->failed,       'parser didnt fail';
 702     ok !$parser->todo_passed,  '... and todo_passed is false';
 703     ok !$parser->parse_errors, '... and parse_errors is false';
 704     ok !$parser->wait,         '... and wait is not set';
 705
 706     ok $parser->exit, '... and exit is set';
 707
 708     ok $parser->has_problems, '... and has_problems';
 709 }
 710
 711 {
 712
 713     # coverage testing of the version states
 714
 715     my $tap = <<'END_TAP';
 716 TAP version 12
 717 1..2
 718 ok 1 - input file opened
 719 ok 2 - Gandalf wins
 720 END_TAP
 721
 722     my $parser = TAP::Parser->new( { tap => $tap } );
 723
 724     _get_results($parser);
 725
 726     my @errors = $parser->parse_errors;
 727
 728     is @errors, 1, 'test too low version number';
 729
 730     like pop @errors,
 731       qr/Explicit TAP version must be at least 13. Got version 12/,
 732       '... and trapped expected version error';
 733
 734     # now too high a version
 735     $tap = <<'END_TAP';
 736 TAP version 14
 737 1..2
 738 ok 1 - input file opened
 739 ok 2 - Gandalf wins
 740 END_TAP
 741
 742     $parser = TAP::Parser->new( { tap => $tap } );
 743
 744     _get_results($parser);
 745
 746     @errors = $parser->parse_errors;
 747
 748     is @errors, 1, 'test too high version number';
 749
 750     like pop @errors,
 751       qr/TAP specified version 14 but we don't know about versions later than 13/,
 752       '... and trapped expected version error';
 753 }
 754
 755 {
 756
 757     # coverage testing of TAP version in the wrong place
 758
 759     my $tap = <<'END_TAP';
 760 1..2
 761 ok 1 - input file opened
 762 TAP version 12
 763 ok 2 - Gandalf wins
 764 END_TAP
 765
 766     my $parser = TAP::Parser->new( { tap => $tap } );
 767
 768     _get_results($parser);
 769
 770     my @errors = $parser->parse_errors;
 771
 772     is @errors, 1, 'test TAP version number in wrong place';
 773
 774     like pop @errors,
 775       qr/If TAP version is present it must be the first line of output/,
 776       '... and trapped expected version error';
 777
 778 }
 779
 780 {
 781
 782     # we're going to bash the internals a bit (but using the API as
 783     # much as possible) to force grammar->tokenise() to fail
 784
 785   # firstly we'll create a stream that dies when its next_raw method is called
 786
 787     package TAP::Parser::Iterator::Dies;
 788
 789     use strict;
 790     use vars qw(@ISA);
 791
 792     @ISA = qw(TAP::Parser::Iterator);
 793
 794     sub next_raw {
 795         die 'this is the dying iterator';
 796     }
 797
 798     # required as part of the TPI interface
 799     sub exit { }
 800     sub wait { }
 801
 802     package main;
 803
 804     # now build a standard parser
 805
 806     my $tap = <<'END_TAP';
 807 1..2
 808 ok 1 - input file opened
 809 ok 2 - Gandalf wins
 810 END_TAP
 811
 812     {
 813         my $parser = TAP::Parser->new( { tap => $tap } );
 814
 815         # build a dying stream
 816         my $stream = TAP::Parser::Iterator::Dies->new;
 817
 818         # now replace the stream - we're forced to us an T::P intenal
 819         # method for this
 820         $parser->_stream($stream);
 821
 822         # build a new grammar
 823         my $grammar = TAP::Parser::Grammar->new(
 824             {   stream => $stream,
 825                 parser => $parser
 826             }
 827         );
 828
 829         # replace our grammar with this new one
 830         $parser->_grammar($grammar);
 831
 832         # now call next on the parser, and the grammar should die
 833         my $result = $parser->next;    # will die in iterator
 834
 835         is $result, undef, 'iterator dies';
 836
 837         my @errors = $parser->parse_errors;
 838         is @errors, 2, '...and caught expected errrors';
 839
 840         like shift @errors, qr/this is the dying iterator/,
 841           '...and it was what we expected';
 842     }
 843
 844     # Do it all again with callbacks to exercise the other code path in
 845     # the unrolled iterator
 846     {
 847         my $parser = TAP::Parser->new( { tap => $tap } );
 848
 849         $parser->callback( 'ALL', sub { } );
 850
 851         # build a dying stream
 852         my $stream = TAP::Parser::Iterator::Dies->new;
 853
 854         # now replace the stream - we're forced to us an T::P intenal
 855         # method for this
 856         $parser->_stream($stream);
 857
 858         # build a new grammar
 859         my $grammar = TAP::Parser::Grammar->new(
 860             {   stream => $stream,
 861                 parser => $parser
 862             }
 863         );
 864
 865         # replace our grammar with this new one
 866         $parser->_grammar($grammar);
 867
 868         # now call next on the parser, and the grammar should die
 869         my $result = $parser->next;    # will die in iterator
 870
 871         is $result, undef, 'iterator dies';
 872
 873         my @errors = $parser->parse_errors;
 874         is @errors, 2, '...and caught expected errrors';
 875
 876         like shift @errors, qr/this is the dying iterator/,
 877           '...and it was what we expected';
 878     }
 879 }
 880
 881 {
 882
 883     # coverage testing of TAP::Parser::_next_state
 884
 885     package TAP::Parser::WithBrokenState;
 886     use vars qw(@ISA);
 887
 888     @ISA = qw( TAP::Parser );
 889
 890     sub _make_state_table {
 891         return { INIT => { plan => { goto => 'FOO' } } };
 892     }
 893
 894     package main;
 895
 896     my $tap = <<'END_TAP';
 897 1..2
 898 ok 1 - input file opened
 899 ok 2 - Gandalf wins
 900 END_TAP
 901
 902     my $parser = TAP::Parser::WithBrokenState->new( { tap => $tap } );
 903
 904     my @die;
 905
 906     eval {
 907         local $SIG{__DIE__} = sub { push @die, @_ };
 908
 909         $parser->next;
 910         $parser->next;
 911     };
 912
 913     is @die, 1, 'detect broken state machine';
 914
 915     like pop @die, qr/Illegal state: FOO/,
 916       '...and the message is as we expect';
 917 }
 918
 919 {
 920
 921     # coverage testing of TAP::Parser::_iter
 922
 923     package TAP::Parser::WithBrokenIter;
 924     use vars qw(@ISA);
 925
 926     @ISA = qw( TAP::Parser );
 927
 928     sub _iter {return}
 929
 930     package main;
 931
 932     my $tap = <<'END_TAP';
 933 1..2
 934 ok 1 - input file opened
 935 ok 2 - Gandalf wins
 936 END_TAP
 937
 938     my $parser = TAP::Parser::WithBrokenIter->new( { tap => $tap } );
 939
 940     my @die;
 941
 942     eval {
 943         local $SIG{__WARN__} = sub { };
 944         local $SIG{__DIE__} = sub { push @die, @_ };
 945
 946         $parser->next;
 947     };
 948
 949     is @die, 1, 'detect broken iter';
 950
 951     like pop @die, qr/Can't use/, '...and the message is as we expect';
 952 }
 953
 954 {
 955
 956     # coverage testing of TAP::Parser::_finish
 957
 958     my $tap = <<'END_TAP';
 959 1..2
 960 ok 1 - input file opened
 961 ok 2 - Gandalf wins
 962 END_TAP
 963
 964     my $parser = TAP::Parser->new( { tap => $tap } );
 965
 966     $parser->tests_run(999);
 967
 968     my @die;
 969
 970     eval {
 971         local $SIG{__DIE__} = sub { push @die, @_ };
 972
 973         _get_results $parser;
 974     };
 975
 976     is @die, 1, 'detect broken test counts';
 977
 978     like pop @die,
 979       qr/Panic: planned test count [(]1001[)] did not equal sum of passed [(]0[)] and failed [(]2[)] tests!/,
 980       '...and the message is as we expect';
 981 }
 982
 983 {
 984
 985     # Sanity check on state table
 986
 987     my $parser      = TAP::Parser->new( { tap => "1..1\nok 1\n" } );
 988     my $state_table = $parser->_make_state_table;
 989     my @states      = sort keys %$state_table;
 990     my @expect      = sort qw(
 991       bailout comment plan pragma test unknown version yaml
 992     );
 993
 994     my %reachable = ( INIT => 1 );
 995
 996     for my $name (@states) {
 997         my $state      = $state_table->{$name};
 998         my @can_handle = sort keys %$state;
 999         is_deeply \@can_handle, \@expect, "token types handled in $name";
1000         for my $type (@can_handle) {
1001             $reachable{$_}++
1002               for grep {defined}
1003               map      { $state->{$type}->{$_} } qw(goto continue);
1004         }
1005     }
1006
1007     is_deeply [ sort keys %reachable ], [@states], "all states reachable";
1008 }
1009
1010 {
1011
1012     # exit, wait, ignore_exit interactions
1013
1014     my @truth = (
1015         [ 0, 0, 0, 0 ],
1016         [ 0, 0, 1, 0 ],
1017         [ 1, 0, 0, 1 ],
1018         [ 1, 0, 1, 0 ],
1019         [ 1, 1, 0, 1 ],
1020         [ 1, 1, 1, 0 ],
1021         [ 0, 1, 0, 1 ],
1022         [ 0, 1, 1, 0 ],
1023     );
1024
1025     for my $t (@truth) {
1026         my ( $wait, $exit, $ignore_exit, $has_problems ) = @$t;
1027         my $test_parser = sub {
1028             my $parser = shift;
1029             $parser->wait($wait);
1030             $parser->exit($exit);
1031             ok $has_problems ? $parser->has_problems : !$parser->has_problems,
1032               "exit=$exit, wait=$wait, ignore=$ignore_exit";
1033         };
1034
1035         my $parser = TAP::Parser->new( { tap => "1..1\nok 1\n" } );
1036         $parser->ignore_exit($ignore_exit);
1037         $test_parser->($parser);
1038
1039         $test_parser->(
1040             TAP::Parser->new(
1041                 { tap => "1..1\nok 1\n", ignore_exit => $ignore_exit }
1042             )
1043         );
1044     }
1045 }