ext/Test-Harness/t/harness.t

   1 #!/usr/bin/perl -w
   2
   3 BEGIN {
   4     if ( $ENV{PERL_CORE} ) {
   5         chdir 't';
   6         @INC = ( '../lib', '../ext/Test-Harness/t/lib' );
   7     }
   8     else {
   9         unshift @INC, 't/lib';
  10     }
  11 }
  12
  13 use strict;
  14
  15 use Test::More;
  16 use IO::c55Capture;
  17
  18 use TAP::Harness;
  19
  20 my $HARNESS = 'TAP::Harness';
  21
  22 my $source_tests
  23   = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/source_tests' : 't/source_tests';
  24 my $sample_tests
  25   = $ENV{PERL_CORE} ? '../ext/Test-Harness/t/sample-tests' : 't/sample-tests';
  26
  27 plan tests => 119;
  28
  29 # note that this test will always pass when run through 'prove'
  30 ok $ENV{HARNESS_ACTIVE},  'HARNESS_ACTIVE env variable should be set';
  31 ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set';
  32
  33 #### For color tests ####
  34
  35 package Colorizer;
  36
  37 sub new { bless {}, shift }
  38 sub can_color {1}
  39
  40 sub set_color {
  41     my ( $self, $output, $color ) = @_;
  42     $output->("[[$color]]");
  43 }
  44
  45 package main;
  46
  47 sub colorize {
  48     my $harness = shift;
  49     $harness->formatter->_colorizer( Colorizer->new );
  50 }
  51
  52 can_ok $HARNESS, 'new';
  53
  54 eval { $HARNESS->new( { no_such_key => 1 } ) };
  55 like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/,
  56   '... and calling it with bad keys should fail';
  57
  58 eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) };
  59 is $@, '', '... and calling it with a non-existent lib is fine';
  60
  61 eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) };
  62 is $@, '', '... and calling it with non-existent libs is fine';
  63
  64 ok my $harness = $HARNESS->new,
  65   'Calling new() without arguments should succeed';
  66
  67 foreach my $test_args ( get_arg_sets() ) {
  68     my %args = %$test_args;
  69     foreach my $key ( sort keys %args ) {
  70         $args{$key} = $args{$key}{in};
  71     }
  72     ok my $harness = $HARNESS->new( {%args} ),
  73       'Calling new() with valid arguments should succeed';
  74     isa_ok $harness, $HARNESS, '... and the object it returns';
  75
  76     while ( my ( $property, $test ) = each %$test_args ) {
  77         my $value = $test->{out};
  78         can_ok $harness, $property;
  79         is_deeply scalar $harness->$property(), $value, $test->{test_name};
  80     }
  81 }
  82
  83 {
  84     my @output;
  85     local $^W;
  86     local *TAP::Formatter::Base::_output = sub {
  87         my $self = shift;
  88         push @output => grep { $_ ne '' }
  89           map {
  90             local $_ = $_;
  91             chomp;
  92             trim($_)
  93           } @_;
  94     };
  95     my $harness = TAP::Harness->new(
  96         { verbosity => 1, formatter_class => "TAP::Formatter::Console" } );
  97     my $harness_whisper = TAP::Harness->new(
  98         { verbosity => -1, formatter_class => "TAP::Formatter::Console" } );
  99     my $harness_mute = TAP::Harness->new(
 100         { verbosity => -2, formatter_class => "TAP::Formatter::Console" } );
 101     my $harness_directives = TAP::Harness->new(
 102         { directives => 1, formatter_class => "TAP::Formatter::Console" } );
 103     my $harness_failures = TAP::Harness->new(
 104         { failures => 1, formatter_class => "TAP::Formatter::Console" } );
 105
 106     colorize($harness);
 107
 108     can_ok $harness, 'runtests';
 109
 110     # normal tests in verbose mode
 111
 112     ok my $aggregate = _runtests( $harness, "$source_tests/harness" ),
 113       '... runtests returns the aggregate';
 114
 115     isa_ok $aggregate, 'TAP::Parser::Aggregator';
 116
 117     chomp(@output);
 118
 119     my @expected = (
 120         "$source_tests/harness ..",
 121         '1..1',
 122         '[[reset]]',
 123         'ok 1 - this is a test',
 124         '[[reset]]',
 125         'ok',
 126         '[[green]]',
 127         'All tests successful.',
 128         '[[reset]]',
 129     );
 130     my $status           = pop @output;
 131     my $expected_status  = qr{^Result: PASS$};
 132     my $summary          = pop @output;
 133     my $expected_summary = qr{^Files=1, Tests=1,  \d+ wallclock secs};
 134
 135     is_deeply \@output, \@expected, '... and the output should be correct';
 136     like $status, $expected_status,
 137       '... and the status line should be correct';
 138     like $summary, $expected_summary,
 139       '... and the report summary should look correct';
 140
 141     # use an alias for test name
 142
 143     @output = ();
 144     ok $aggregate
 145       = _runtests( $harness, [ "$source_tests/harness", 'My Nice Test' ] ),
 146       '... runtests returns the aggregate';
 147
 148     isa_ok $aggregate, 'TAP::Parser::Aggregator';
 149
 150     chomp(@output);
 151
 152     @expected = (
 153         'My Nice Test ..',
 154         '1..1',
 155         '[[reset]]',
 156         'ok 1 - this is a test',
 157         '[[reset]]',
 158         'ok',
 159         '[[green]]',
 160         'All tests successful.',
 161         '[[reset]]',
 162     );
 163     $status           = pop @output;
 164     $expected_status  = qr{^Result: PASS$};
 165     $summary          = pop @output;
 166     $expected_summary = qr{^Files=1, Tests=1,  \d+ wallclock secs};
 167
 168     is_deeply \@output, \@expected, '... and the output should be correct';
 169     like $status, $expected_status,
 170       '... and the status line should be correct';
 171     like $summary, $expected_summary,
 172       '... and the report summary should look correct';
 173
 174     # run same test twice
 175
 176     @output = ();
 177     ok $aggregate = _runtests(
 178         $harness, [ "$source_tests/harness", 'My Nice Test' ],
 179         [ "$source_tests/harness", 'My Nice Test Again' ]
 180       ),
 181       '... runtests returns the aggregate';
 182
 183     isa_ok $aggregate, 'TAP::Parser::Aggregator';
 184
 185     chomp(@output);
 186
 187     @expected = (
 188         'My Nice Test ........',
 189         '1..1',
 190         '[[reset]]',
 191         'ok 1 - this is a test',
 192         '[[reset]]',
 193         'ok',
 194         'My Nice Test Again ..',
 195         '1..1',
 196         '[[reset]]',
 197         'ok 1 - this is a test',
 198         '[[reset]]',
 199         'ok',
 200         '[[green]]',
 201         'All tests successful.',
 202         '[[reset]]',
 203     );
 204     $status           = pop @output;
 205     $expected_status  = qr{^Result: PASS$};
 206     $summary          = pop @output;
 207     $expected_summary = qr{^Files=2, Tests=2,  \d+ wallclock secs};
 208
 209     is_deeply \@output, \@expected, '... and the output should be correct';
 210     like $status, $expected_status,
 211       '... and the status line should be correct';
 212     like $summary, $expected_summary,
 213       '... and the report summary should look correct';
 214
 215     # normal tests in quiet mode
 216
 217     @output = ();
 218     _runtests( $harness_whisper, "$source_tests/harness" );
 219
 220     chomp(@output);
 221     @expected = (
 222         "$source_tests/harness ..",
 223         'ok',
 224         'All tests successful.',
 225     );
 226
 227     $status           = pop @output;
 228     $expected_status  = qr{^Result: PASS$};
 229     $summary          = pop @output;
 230     $expected_summary = qr/^Files=1, Tests=1,  \d+ wallclock secs/;
 231
 232     is_deeply \@output, \@expected, '... and the output should be correct';
 233     like $status, $expected_status,
 234       '... and the status line should be correct';
 235     like $summary, $expected_summary,
 236       '... and the report summary should look correct';
 237
 238     # normal tests in really_quiet mode
 239
 240     @output = ();
 241     _runtests( $harness_mute, "$source_tests/harness" );
 242
 243     chomp(@output);
 244     @expected = (
 245         'All tests successful.',
 246     );
 247
 248     $status           = pop @output;
 249     $expected_status  = qr{^Result: PASS$};
 250     $summary          = pop @output;
 251     $expected_summary = qr/^Files=1, Tests=1,  \d+ wallclock secs/;
 252
 253     is_deeply \@output, \@expected, '... and the output should be correct';
 254     like $status, $expected_status,
 255       '... and the status line should be correct';
 256     like $summary, $expected_summary,
 257       '... and the report summary should look correct';
 258
 259     # normal tests with failures
 260
 261     @output = ();
 262     _runtests( $harness, "$source_tests/harness_failure" );
 263
 264     $status  = pop @output;
 265     $summary = pop @output;
 266
 267     like $status, qr{^Result: FAIL$},
 268       '... and the status line should be correct';
 269
 270     my @summary = @output[ 18 .. $#output ];
 271     @output = @output[ 0 .. 17 ];
 272
 273     @expected = (
 274         "$source_tests/harness_failure ..",
 275         '1..2',
 276         '[[reset]]',
 277         'ok 1 - this is a test',
 278         '[[reset]]',
 279         '[[red]]',
 280         'not ok 2 - this is another test',
 281         '[[reset]]',
 282         q{#   Failed test 'this is another test'},
 283         '[[reset]]',
 284         '#   in harness_failure.t at line 5.',
 285         '[[reset]]',
 286         q{#          got: 'waffle'},
 287         '[[reset]]',
 288         q{#     expected: 'yarblokos'},
 289         '[[reset]]',
 290         '[[red]]',
 291         'Failed 1/2 subtests',
 292     );
 293
 294     is_deeply \@output, \@expected,
 295       '... and failing test output should be correct';
 296
 297     my @expected_summary = (
 298         '[[reset]]',
 299         'Test Summary Report',
 300         '-------------------',
 301         '[[red]]',
 302         "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
 303         '[[reset]]',
 304         '[[red]]',
 305         'Failed test:',
 306         '[[reset]]',
 307         '[[red]]',
 308         '2',
 309         '[[reset]]',
 310     );
 311
 312     is_deeply \@summary, \@expected_summary,
 313       '... and the failure summary should also be correct';
 314
 315     # quiet tests with failures
 316
 317     @output = ();
 318     _runtests( $harness_whisper, "$source_tests/harness_failure" );
 319
 320     $status   = pop @output;
 321     $summary  = pop @output;
 322     @expected = (
 323         "$source_tests/harness_failure ..",
 324         'Failed 1/2 subtests',
 325         'Test Summary Report',
 326         '-------------------',
 327         "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
 328         'Failed test:',
 329         '2',
 330     );
 331
 332     like $status, qr{^Result: FAIL$},
 333       '... and the status line should be correct';
 334
 335     is_deeply \@output, \@expected,
 336       '... and failing test output should be correct';
 337
 338     # really quiet tests with failures
 339
 340     @output = ();
 341     _runtests( $harness_mute, "$source_tests/harness_failure" );
 342
 343     $status   = pop @output;
 344     $summary  = pop @output;
 345     @expected = (
 346         'Test Summary Report',
 347         '-------------------',
 348         "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
 349         'Failed test:',
 350         '2',
 351     );
 352
 353     like $status, qr{^Result: FAIL$},
 354       '... and the status line should be correct';
 355
 356     is_deeply \@output, \@expected,
 357       '... and failing test output should be correct';
 358
 359     # only show directives
 360
 361     @output = ();
 362     _runtests(
 363         $harness_directives,
 364         "$source_tests/harness_directives"
 365     );
 366
 367     chomp(@output);
 368
 369     @expected = (
 370         "$source_tests/harness_directives ..",
 371         'not ok 2 - we have a something # TODO some output',
 372         "ok 3 houston, we don't have liftoff # SKIP no funding",
 373         'ok',
 374         'All tests successful.',
 375
 376         # ~TODO {{{ this should be an option
 377         #'Test Summary Report',
 378         #'-------------------',
 379         #"$source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)",
 380         #'Tests skipped:',
 381         #'3',
 382         # }}}
 383     );
 384
 385     $status           = pop @output;
 386     $summary          = pop @output;
 387     $expected_summary = qr/^Files=1, Tests=3,  \d+ wallclock secs/;
 388
 389     is_deeply \@output, \@expected, '... and the output should be correct';
 390     like $summary, $expected_summary,
 391       '... and the report summary should look correct';
 392
 393     like $status, qr{^Result: PASS$},
 394       '... and the status line should be correct';
 395
 396     # normal tests with bad tap
 397
 398     # install callback handler
 399     my $parser;
 400     my $callback_count = 0;
 401
 402     my @callback_log = ();
 403
 404     for my $evt (qw(parser_args made_parser before_runtests after_runtests)) {
 405         $harness->callback(
 406             $evt => sub {
 407                 push @callback_log, $evt;
 408             }
 409         );
 410     }
 411
 412     $harness->callback(
 413         made_parser => sub {
 414             $parser = shift;
 415             $callback_count++;
 416         }
 417     );
 418
 419     @output = ();
 420     _runtests( $harness, "$source_tests/harness_badtap" );
 421     chomp(@output);
 422
 423     @output   = map { trim($_) } @output;
 424     $status   = pop @output;
 425     @summary  = @output[ 12 .. ( $#output - 1 ) ];
 426     @output   = @output[ 0 .. 11 ];
 427     @expected = (
 428         "$source_tests/harness_badtap ..",
 429         '1..2',
 430         '[[reset]]',
 431         'ok 1 - this is a test',
 432         '[[reset]]',
 433         '[[red]]',
 434         'not ok 2 - this is another test',
 435         '[[reset]]',
 436         '1..2',
 437         '[[reset]]',
 438         '[[red]]',
 439         'Failed 1/2 subtests',
 440     );
 441     is_deeply \@output, \@expected,
 442       '... and failing test output should be correct';
 443     like $status, qr{^Result: FAIL$},
 444       '... and the status line should be correct';
 445     @expected_summary = (
 446         '[[reset]]',
 447         'Test Summary Report',
 448         '-------------------',
 449         '[[red]]',
 450         "$source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)",
 451         '[[reset]]',
 452         '[[red]]',
 453         'Failed test:',
 454         '[[reset]]',
 455         '[[red]]',
 456         '2',
 457         '[[reset]]',
 458         '[[red]]',
 459         'Parse errors: More than one plan found in TAP output',
 460         '[[reset]]',
 461     );
 462     is_deeply \@summary, \@expected_summary,
 463       '... and the badtap summary should also be correct';
 464
 465     cmp_ok( $callback_count, '==', 1, 'callback called once' );
 466     is_deeply(
 467         \@callback_log,
 468         [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ],
 469         'callback log matches'
 470     );
 471     isa_ok $parser, 'TAP::Parser';
 472
 473     # coverage testing for _should_show_failures
 474     # only show failures
 475
 476     @output = ();
 477     _runtests( $harness_failures, "$source_tests/harness_failure" );
 478
 479     chomp(@output);
 480
 481     @expected = (
 482         "$source_tests/harness_failure ..",
 483         'not ok 2 - this is another test',
 484         'Failed 1/2 subtests',
 485         'Test Summary Report',
 486         '-------------------',
 487         "$source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)",
 488         'Failed test:',
 489         '2',
 490     );
 491
 492     $status  = pop @output;
 493     $summary = pop @output;
 494
 495     like $status, qr{^Result: FAIL$},
 496       '... and the status line should be correct';
 497     $expected_summary = qr/^Files=1, Tests=2,  \d+ wallclock secs/;
 498     is_deeply \@output, \@expected, '... and the output should be correct';
 499
 500     # check the status output for no tests
 501
 502     @output = ();
 503     _runtests( $harness_failures, "$sample_tests/no_output" );
 504
 505     chomp(@output);
 506
 507     @expected = (
 508         "$sample_tests/no_output ..",
 509         'No subtests run',
 510         'Test Summary Report',
 511         '-------------------',
 512         "$sample_tests/no_output (Wstat: 0 Tests: 0 Failed: 0)",
 513         'Parse errors: No plan found in TAP output',
 514     );
 515
 516     $status  = pop @output;
 517     $summary = pop @output;
 518
 519     like $status, qr{^Result: FAIL$},
 520       '... and the status line should be correct';
 521     $expected_summary = qr/^Files=1, Tests=2,  \d+ wallclock secs/;
 522     is_deeply \@output, \@expected, '... and the output should be correct';
 523
 524     #XXXX
 525 }
 526
 527 # make sure we can exec something ... anything!
 528 SKIP: {
 529
 530     my $cat = '/bin/cat';
 531     unless ( -e $cat ) {
 532         skip "no '$cat'", 2;
 533     }
 534
 535     my $capture = IO::c55Capture->new_handle;
 536     my $harness = TAP::Harness->new(
 537         {   verbosity => -2,
 538             stdout    => $capture,
 539             exec      => [$cat],
 540         }
 541     );
 542
 543     eval {
 544         _runtests(
 545             $harness,
 546             $ENV{PERL_CORE}
 547             ? '../ext/Test-Harness/t/data/catme.1'
 548             : 't/data/catme.1'
 549         );
 550     };
 551
 552     my @output = tied($$capture)->dump;
 553     my $status = pop @output;
 554     like $status, qr{^Result: PASS$},
 555       '... and the status line should be correct';
 556     pop @output;    # get rid of summary line
 557     my $answer = pop @output;
 558     is( $answer, "All tests successful.\n", 'cat meows' );
 559 }
 560
 561 # make sure that we can exec with a code ref.
 562 {
 563     my $capture = IO::c55Capture->new_handle;
 564     my $harness = TAP::Harness->new(
 565         {   verbosity => -2,
 566             stdout    => $capture,
 567             exec      => sub {undef},
 568         }
 569     );
 570
 571     _runtests( $harness, "$source_tests/harness" );
 572
 573     my @output = tied($$capture)->dump;
 574     my $status = pop @output;
 575     like $status, qr{^Result: PASS$},
 576       '... and the status line should be correct';
 577     pop @output;    # get rid of summary line
 578     my $answer = pop @output;
 579     is( $answer, "All tests successful.\n", 'cat meows' );
 580 }
 581
 582 # Exec with a coderef that returns an arrayref
 583 SKIP: {
 584     my $cat = '/bin/cat';
 585     unless ( -e $cat ) {
 586         skip "no '$cat'", 2;
 587     }
 588
 589     my $capture = IO::c55Capture->new_handle;
 590     my $harness = TAP::Harness->new(
 591         {   verbosity => -2,
 592             stdout    => $capture,
 593             exec      => sub {
 594                 return [
 595                     $cat,
 596                     $ENV{PERL_CORE}
 597                     ? '../ext/Test-Harness/t/data/catme.1'
 598                     : 't/data/catme.1'
 599                 ];
 600             },
 601         }
 602     );
 603
 604     _runtests( $harness, "$source_tests/harness" );
 605
 606     my @output = tied($$capture)->dump;
 607     my $status = pop @output;
 608     like $status, qr{^Result: PASS$},
 609       '... and the status line should be correct';
 610     pop @output;    # get rid of summary line
 611     my $answer = pop @output;
 612     is( $answer, "All tests successful.\n", 'cat meows' );
 613 }
 614
 615 # Exec with a coderef that returns raw TAP
 616 {
 617     my $capture = IO::c55Capture->new_handle;
 618     my $harness = TAP::Harness->new(
 619         {   verbosity => -2,
 620             stdout    => $capture,
 621             exec      => sub {
 622                 return "1..1\nok 1 - raw TAP\n";
 623             },
 624         }
 625     );
 626
 627     _runtests( $harness, "$source_tests/harness" );
 628
 629     my @output = tied($$capture)->dump;
 630     my $status = pop @output;
 631     like $status, qr{^Result: PASS$},
 632       '... and the status line should be correct';
 633     pop @output;    # get rid of summary line
 634     my $answer = pop @output;
 635     is( $answer, "All tests successful.\n", 'cat meows' );
 636 }
 637
 638 # Exec with a coderef that returns a filehandle
 639 {
 640     my $capture = IO::c55Capture->new_handle;
 641     my $harness = TAP::Harness->new(
 642         {   verbosity => -2,
 643             stdout    => $capture,
 644             exec      => sub {
 645                 open my $fh,
 646                   $ENV{PERL_CORE}
 647                   ? '../ext/Test-Harness/t/data/catme.1'
 648                   : 't/data/catme.1';
 649                 return $fh;
 650             },
 651         }
 652     );
 653
 654     _runtests( $harness, "$source_tests/harness" );
 655
 656     my @output = tied($$capture)->dump;
 657     my $status = pop @output;
 658     like $status, qr{^Result: PASS$},
 659       '... and the status line should be correct';
 660     pop @output;    # get rid of summary line
 661     my $answer = pop @output;
 662     is( $answer, "All tests successful.\n", 'cat meows' );
 663 }
 664
 665 # catches "exec accumulates arguments" issue (r77)
 666 {
 667     my $capture = IO::c55Capture->new_handle;
 668     my $harness = TAP::Harness->new(
 669         {   verbosity => -2,
 670             stdout    => $capture,
 671             exec      => [$^X]
 672         }
 673     );
 674
 675     _runtests(
 676         $harness,
 677         "$source_tests/harness_complain"
 678         ,    # will get mad if run with args
 679         "$source_tests/harness",
 680     );
 681
 682     my @output = tied($$capture)->dump;
 683     my $status = pop @output;
 684     like $status, qr{^Result: PASS$},
 685       '... and the status line should be correct';
 686     pop @output;    # get rid of summary line
 687     is( $output[-1], "All tests successful.\n",
 688         'No exec accumulation'
 689     );
 690 }
 691
 692 sub trim {
 693     $_[0] =~ s/^\s+|\s+$//g;
 694     return $_[0];
 695 }
 696
 697 sub liblist {
 698     return [ map {"-I$_"} @_ ];
 699 }
 700
 701 sub get_arg_sets {
 702
 703     # keys are keys to new()
 704     return {
 705         lib => {
 706             in        => 'lib',
 707             out       => liblist('lib'),
 708             test_name => '... a single lib switch should be correct'
 709         },
 710         verbosity => {
 711             in        => 1,
 712             out       => 1,
 713             test_name => '... and we should be able to set verbosity to 1'
 714         },
 715
 716         # verbose => {
 717         #     in        => 1,
 718         #     out       => 1,
 719         #     test_name => '... and we should be able to set verbose to true'
 720         # },
 721       },
 722       { lib => {
 723             in        => [ 'lib',        't' ],
 724             out       => liblist( 'lib', 't' ),
 725             test_name => '... multiple lib dirs should be correct'
 726         },
 727         verbosity => {
 728             in        => 0,
 729             out       => 0,
 730             test_name => '... and we should be able to set verbosity to 0'
 731         },
 732
 733         # verbose => {
 734         #     in        => 0,
 735         #     out       => 0,
 736         #     test_name => '... and we should be able to set verbose to false'
 737         # },
 738       },
 739       { switches => {
 740             in        => [ '-T', '-w', '-T' ],
 741             out       => [ '-T', '-w', '-T' ],
 742             test_name => '... duplicate switches should remain',
 743         },
 744         failures => {
 745             in  => 1,
 746             out => 1,
 747             test_name =>
 748               '... and we should be able to set failures to true',
 749         },
 750         verbosity => {
 751             in        => -1,
 752             out       => -1,
 753             test_name => '... and we should be able to set verbosity to -1'
 754         },
 755
 756         # quiet => {
 757         #     in        => 1,
 758         #     out       => 1,
 759         #     test_name => '... and we should be able to set quiet to false'
 760         # },
 761       },
 762
 763       { verbosity => {
 764             in        => -2,
 765             out       => -2,
 766             test_name => '... and we should be able to set verbosity to -2'
 767         },
 768
 769         # really_quiet => {
 770         #     in  => 1,
 771         #     out => 1,
 772         #     test_name =>
 773         #       '... and we should be able to set really_quiet to true',
 774         # },
 775         exec => {
 776             in  => $^X,
 777             out => $^X,
 778             test_name =>
 779               '... and we should be able to set the executable',
 780         },
 781       },
 782       { switches => {
 783             in  => 'T',
 784             out => ['T'],
 785             test_name =>
 786               '... leading dashes (-) on switches are not optional',
 787         },
 788       },
 789       { switches => {
 790             in        => '-T',
 791             out       => ['-T'],
 792             test_name => '... we should be able to set switches',
 793         },
 794         failures => {
 795             in        => 1,
 796             out       => 1,
 797             test_name => '... and we should be able to set failures to true'
 798         },
 799       };
 800 }
 801
 802 sub _runtests {
 803     my ( $harness, @tests ) = @_;
 804     local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
 805     my $aggregate = $harness->runtests(@tests);
 806     return $aggregate;
 807 }
 808
 809 {
 810
 811     # coverage tests for ctor
 812
 813     my $harness = TAP::Harness->new(
 814         {   timer  => 0,
 815             errors => 1,
 816             merge  => 2,
 817
 818             # formatter => 3,
 819         }
 820     );
 821
 822     is $harness->timer(), 0, 'timer getter';
 823     is $harness->timer(10), 10, 'timer setter';
 824     is $harness->errors(), 1, 'errors getter';
 825     is $harness->errors(10), 10, 'errors setter';
 826     is $harness->merge(), 2, 'merge getter';
 827     is $harness->merge(10), 10, 'merge setter';
 828
 829     # jobs accessor
 830     is $harness->jobs(), 1, 'jobs';
 831 }
 832
 833 {
 834
 835 # coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor
 836
 837     # the coverage tests are
 838     # 1. ref $ref => false
 839     # 2. ref => ! GLOB and ref->can(print)
 840     # 3. ref $ref => GLOB
 841
 842     # case 1
 843
 844     my @die;
 845
 846     eval {
 847         local $SIG{__DIE__} = sub { push @die, @_ };
 848
 849         my $harness = TAP::Harness->new(
 850             {   stdout => bless {}, '0',    # how evil is THAT !!!
 851             }
 852         );
 853     };
 854
 855     is @die, 1, 'bad filehandle to stdout';
 856     like pop @die, qr/option 'stdout' needs a filehandle/,
 857       '... and we died as expected';
 858
 859     # case 2
 860
 861     @die = ();
 862
 863     package Printable;
 864
 865     sub new { return bless {}, shift }
 866
 867     sub print {return}
 868
 869     package main;
 870
 871     my $harness = TAP::Harness->new(
 872         {   stdout => Printable->new(),
 873         }
 874     );
 875
 876     isa_ok $harness, 'TAP::Harness';
 877
 878     # case 3
 879
 880     @die = ();
 881
 882     $harness = TAP::Harness->new(
 883         {   stdout => bless {}, 'GLOB',    # again with the evil
 884         }
 885     );
 886
 887     isa_ok $harness, 'TAP::Harness';
 888 }
 889
 890 {
 891
 892     # coverage testing of lib/switches accessor
 893     my $harness = TAP::Harness->new;
 894
 895     my @die;
 896
 897     eval {
 898         local $SIG{__DIE__} = sub { push @die, @_ };
 899
 900         $harness->switches(qw( too many arguments));
 901     };
 902
 903     is @die, 1, 'too many arguments to accessor';
 904
 905     like pop @die, qr/Too many arguments to method 'switches'/,
 906       '...and we died as expected';
 907
 908     $harness->switches('simple scalar');
 909
 910     my $arrref = $harness->switches;
 911     is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref';
 912 }
 913
 914 {
 915
 916     # coverage tests for the basically untested T::H::_open_spool
 917
 918     my @spool = (
 919         (   $ENV{PERL_CORE}
 920             ? ( File::Spec->updir(), 'ext', 'Test-Harness' )
 921             : ()
 922         ),
 923         ( 't', 'spool' )
 924     );
 925     $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool);
 926
 927 # now given that we're going to be writing stuff to the file system, make sure we have
 928 # a cleanup hook
 929
 930     END {
 931         use File::Path;
 932
 933         # remove the tree if we made it this far
 934         rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
 935           if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
 936     }
 937
 938     my $harness = TAP::Harness->new( { verbosity => -2 } );
 939
 940     can_ok $harness, 'runtests';
 941
 942     # normal tests in verbose mode
 943
 944     my $parser
 945       = $harness->runtests( File::Spec->catfile( $source_tests, 'harness' ) );
 946
 947     isa_ok $parser, 'TAP::Parser::Aggregator',
 948       '... runtests returns the aggregate';
 949
 950     ok -e File::Spec->catfile(
 951         $ENV{PERL_TEST_HARNESS_DUMP_TAP},
 952         $source_tests, 'harness'
 953     );
 954 }
 955
 956 {
 957
 958     # test name munging
 959     my @cases = (
 960         {   name   => 'all the same',
 961             input  => [ 'foo.t', 'bar.t', 'fletz.t' ],
 962             output => [
 963                 [ 'foo.t', 'foo.t' ], [ 'bar.t', 'bar.t' ],
 964                 [ 'fletz.t', 'fletz.t' ]
 965             ],
 966         },
 967         {   name   => 'all the same, already cooked',
 968             input  => [ 'foo.t', [ 'bar.t', 'brip' ], 'fletz.t' ],
 969             output => [
 970                 [ 'foo.t', 'foo.t' ], [ 'bar.t', 'brip' ],
 971                 [ 'fletz.t', 'fletz.t' ]
 972             ],
 973         },
 974         {   name   => 'different exts',
 975             input  => [ 'foo.t', 'bar.u', 'fletz.v' ],
 976             output => [
 977                 [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bar.u' ],
 978                 [ 'fletz.v', 'fletz.v' ]
 979             ],
 980         },
 981         {   name   => 'different exts, one already cooked',
 982             input  => [ 'foo.t', [ 'bar.u', 'bam' ], 'fletz.v' ],
 983             output => [
 984                 [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam' ],
 985                 [ 'fletz.v', 'fletz.v' ]
 986             ],
 987         },
 988         {   name   => 'different exts, two already cooked',
 989             input  => [ 'foo.t', [ 'bar.u', 'bam.q' ], [ 'fletz.v', 'boo' ] ],
 990             output => [
 991                 [ 'foo.t', 'foo.t' ], [ 'bar.u', 'bam.q' ],
 992                 [ 'fletz.v', 'boo' ]
 993             ],
 994         },
 995     );
 996
 997     for my $case (@cases) {
 998         is_deeply [ TAP::Harness->_add_descriptions( @{ $case->{input} } ) ],
 999           $case->{output}, '_add_descriptions: ' . $case->{name};
1000     }
1001 }