cpan/Test-Harness/t/parse.t

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