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