cpan/Test-Harness/t/harness.t

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