git.maemo.org Git - pkg-perl/blob - deb-src/libtest-harness-perl/libtest-harness-perl-3.12/t/harness.t

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