lib/TAP/Harness.pm

   1 package TAP::Harness;
   2
   3 use strict;
   4 use Carp;
   5
   6 use File::Spec;
   7 use File::Path;
   8 use IO::Handle;
   9
  10 use TAP::Base;
  11 use TAP::Parser;
  12 use TAP::Parser::Aggregator;
  13 use TAP::Parser::Multiplexer;
  14
  15 use vars qw($VERSION @ISA);
  16
  17 @ISA = qw(TAP::Base);
  18
  19 =head1 NAME
  20
  21 TAP::Harness - Run test scripts with statistics
  22
  23 =head1 VERSION
  24
  25 Version 3.10
  26
  27 =cut
  28
  29 $VERSION = '3.10';
  30
  31 $ENV{HARNESS_ACTIVE}  = 1;
  32 $ENV{HARNESS_VERSION} = $VERSION;
  33
  34 END {
  35
  36     # For VMS.
  37     delete $ENV{HARNESS_ACTIVE};
  38     delete $ENV{HARNESS_VERSION};
  39 }
  40
  41 =head1 DESCRIPTION
  42
  43 This is a simple test harness which allows tests to be run and results
  44 automatically aggregated and output to STDOUT.
  45
  46 =head1 SYNOPSIS
  47
  48  use TAP::Harness;
  49  my $harness = TAP::Harness->new( \%args );
  50  $harness->runtests(@tests);
  51
  52 =cut
  53
  54 my %VALIDATION_FOR;
  55 my @FORMATTER_ARGS;
  56
  57 sub _error {
  58     my $self = shift;
  59     return $self->{error} unless @_;
  60     $self->{error} = shift;
  61 }
  62
  63 BEGIN {
  64
  65     @FORMATTER_ARGS = qw(
  66       directives verbosity timer failures errors stdout color
  67     );
  68
  69     %VALIDATION_FOR = (
  70         lib => sub {
  71             my ( $self, $libs ) = @_;
  72             $libs = [$libs] unless 'ARRAY' eq ref $libs;
  73
  74             return [ map {"-I$_"} @$libs ];
  75         },
  76         switches        => sub { shift; shift },
  77         exec            => sub { shift; shift },
  78         merge           => sub { shift; shift },
  79         formatter_class => sub { shift; shift },
  80         formatter       => sub { shift; shift },
  81         jobs            => sub { shift; shift },
  82         fork            => sub { shift; shift },
  83         test_args       => sub { shift; shift },
  84     );
  85
  86     for my $method ( sort keys %VALIDATION_FOR ) {
  87         no strict 'refs';
  88         if ( $method eq 'lib' || $method eq 'switches' ) {
  89             *{$method} = sub {
  90                 my $self = shift;
  91                 unless (@_) {
  92                     $self->{$method} ||= [];
  93                     return wantarray
  94                       ? @{ $self->{$method} }
  95                       : $self->{$method};
  96                 }
  97                 $self->_croak("Too many arguments to method '$method'")
  98                   if @_ > 1;
  99                 my $args = shift;
 100                 $args = [$args] unless ref $args;
 101                 $self->{$method} = $args;
 102                 return $self;
 103             };
 104         }
 105         else {
 106             *{$method} = sub {
 107                 my $self = shift;
 108                 return $self->{$method} unless @_;
 109                 $self->{$method} = shift;
 110             };
 111         }
 112     }
 113
 114     for my $method (@FORMATTER_ARGS) {
 115         no strict 'refs';
 116         *{$method} = sub {
 117             my $self = shift;
 118             return $self->formatter->$method(@_);
 119         };
 120     }
 121 }
 122
 123 ##############################################################################
 124
 125 =head1 METHODS
 126
 127 =head2 Class Methods
 128
 129 =head3 C<new>
 130
 131  my %args = (
 132     verbosity => 1,
 133     lib     => [ 'lib', 'blib/lib' ],
 134  )
 135  my $harness = TAP::Harness->new( \%args );
 136
 137 The constructor returns a new C<TAP::Harness> object.  It accepts an optional
 138 hashref whose allowed keys are:
 139
 140 =over 4
 141
 142 =item * C<verbosity>
 143
 144 Set the verbosity level:
 145
 146      1   verbose        Print individual test results to STDOUT.
 147      0   normal
 148     -1   quiet          Suppress some test output (mostly failures
 149                         while tests are running).
 150     -2   really quiet   Suppress everything but the tests summary.
 151
 152 =item * C<timer>
 153
 154 Append run time for each test to output. Uses L<Time::HiRes> if available.
 155
 156 =item * C<failures>
 157
 158 Only show test failures (this is a no-op if C<verbose> is selected).
 159
 160 =item * C<lib>
 161
 162 Accepts a scalar value or array ref of scalar values indicating which paths to
 163 allowed libraries should be included if Perl tests are executed.  Naturally,
 164 this only makes sense in the context of tests written in Perl.
 165
 166 =item * C<switches>
 167
 168 Accepts a scalar value or array ref of scalar values indicating which switches
 169 should be included if Perl tests are executed.  Naturally, this only makes
 170 sense in the context of tests written in Perl.
 171
 172 =item * C<test_args>
 173
 174 A reference to an C<@INC> style array of arguments to be passed to each
 175 test program.
 176
 177 =item * C<color>
 178
 179 Attempt to produce color output.
 180
 181 =item * C<exec>
 182
 183 Typically, Perl tests are run through this.  However, anything which spits out
 184 TAP is fine.  You can use this argument to specify the name of the program
 185 (and optional switches) to run your tests with:
 186
 187   exec => ['/usr/bin/ruby', '-w']
 188
 189 =item * C<merge>
 190
 191 If C<merge> is true the harness will create parsers that merge STDOUT
 192 and STDERR together for any processes they start.
 193
 194 =item * C<formatter_class>
 195
 196 The name of the class to use to format output. The default is
 197 L<TAP::Formatter::Console>.
 198
 199 =item * C<formatter>
 200
 201 If set C<formatter> must be an object that is capable of formatting the
 202 TAP output. See L<TAP::Formatter::Console> for an example.
 203
 204 =item * C<errors>
 205
 206 If parse errors are found in the TAP output, a note of this will be made
 207 in the summary report.  To see all of the parse errors, set this argument to
 208 true:
 209
 210   errors => 1
 211
 212 =item * C<directives>
 213
 214 If set to a true value, only test results with directives will be displayed.
 215 This overrides other settings such as C<verbose> or C<failures>.
 216
 217 =item * C<stdout>
 218
 219 A filehandle for catching standard output.
 220
 221 =back
 222
 223 Any keys for which the value is C<undef> will be ignored.
 224
 225 =cut
 226
 227 # new supplied by TAP::Base
 228
 229 {
 230     my @legal_callback = qw(
 231       parser_args
 232       made_parser
 233       before_runtests
 234       after_runtests
 235       after_test
 236     );
 237
 238     sub _initialize {
 239         my ( $self, $arg_for ) = @_;
 240         $arg_for ||= {};
 241
 242         $self->SUPER::_initialize( $arg_for, \@legal_callback );
 243         my %arg_for = %$arg_for;    # force a shallow copy
 244
 245         for my $name ( sort keys %VALIDATION_FOR ) {
 246             my $property = delete $arg_for{$name};
 247             if ( defined $property ) {
 248                 my $validate = $VALIDATION_FOR{$name};
 249
 250                 my $value = $self->$validate($property);
 251                 if ( $self->_error ) {
 252                     $self->_croak;
 253                 }
 254                 $self->$name($value);
 255             }
 256         }
 257
 258         $self->jobs(1) unless defined $self->jobs;
 259
 260         unless ( $self->formatter ) {
 261
 262             $self->formatter_class( my $class = $self->formatter_class
 263                   || 'TAP::Formatter::Console' );
 264
 265             croak "Bad module name $class"
 266               unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
 267
 268             eval "require $class";
 269             $self->_croak("Can't load $class") if $@;
 270
 271             # This is a little bodge to preserve legacy behaviour. It's
 272             # pretty horrible that we know which args are destined for
 273             # the formatter.
 274             my %formatter_args = ( jobs => $self->jobs );
 275             for my $name (@FORMATTER_ARGS) {
 276                 if ( defined( my $property = delete $arg_for{$name} ) ) {
 277                     $formatter_args{$name} = $property;
 278                 }
 279             }
 280
 281             $self->formatter( $class->new( \%formatter_args ) );
 282         }
 283
 284         if ( my @props = sort keys %arg_for ) {
 285             $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
 286         }
 287
 288         return $self;
 289     }
 290 }
 291
 292 ##############################################################################
 293
 294 =head2 Instance Methods
 295
 296 =head3 C<runtests>
 297
 298     $harness->runtests(@tests);
 299
 300 Accepts and array of C<@tests> to be run.  This should generally be the names
 301 of test files, but this is not required.  Each element in C<@tests> will be
 302 passed to C<TAP::Parser::new()> as a C<source>.  See L<TAP::Parser> for more
 303 information.
 304
 305 It is possible to provide aliases that will be displayed in place of the
 306 test name by supplying the test as a reference to an array containing
 307 C<< [ $test, $alias ] >>:
 308
 309     $harness->runtests( [ 't/foo.t', 'Foo Once' ],
 310                         [ 't/foo.t', 'Foo Twice' ] );
 311
 312 Normally it is an error to attempt to run the same test twice. Aliases
 313 allow you to overcome this limitation by giving each run of the test a
 314 unique name.
 315
 316 Tests will be run in the order found.
 317
 318 If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
 319 should name a directory into which a copy of the raw TAP for each test
 320 will be written. TAP is written to files named for each test.
 321 Subdirectories will be created as needed.
 322
 323 Returns a L<TAP::Parser::Aggregator> containing the test results.
 324
 325 =cut
 326
 327 sub runtests {
 328     my ( $self, @tests ) = @_;
 329
 330     my $aggregate = TAP::Parser::Aggregator->new;
 331
 332     $self->_make_callback( 'before_runtests', $aggregate );
 333     $aggregate->start;
 334     $self->aggregate_tests( $aggregate, @tests );
 335     $aggregate->stop;
 336     $self->formatter->summary($aggregate);
 337     $self->_make_callback( 'after_runtests', $aggregate );
 338
 339     return $aggregate;
 340 }
 341
 342 sub _after_test {
 343     my ( $self, $aggregate, $test, $parser ) = @_;
 344
 345     $self->_make_callback( 'after_test', $test, $parser );
 346     $aggregate->add( $test->[1], $parser );
 347 }
 348
 349 sub _aggregate_forked {
 350     my ( $self, $aggregate, @tests ) = @_;
 351
 352     eval { require Parallel::Iterator };
 353
 354     croak "Parallel::Iterator required for --fork option ($@)"
 355       if $@;
 356
 357     my $iter = Parallel::Iterator::iterate(
 358         { workers => $self->jobs || 0 },
 359         sub {
 360             my ( $id, $test ) = @_;
 361
 362             my ( $parser, $session ) = $self->make_parser($test);
 363
 364             while ( defined( my $result = $parser->next ) ) {
 365                 exit 1 if $result->is_bailout;
 366             }
 367
 368             $self->finish_parser( $parser, $session );
 369
 370             # Can't serialise coderefs...
 371             delete $parser->{_iter};
 372             delete $parser->{_stream};
 373             delete $parser->{_grammar};
 374             return $parser;
 375         },
 376         \@tests
 377     );
 378
 379     while ( my ( $id, $parser ) = $iter->() ) {
 380         $self->_after_test( $aggregate, $tests[$id], $parser );
 381     }
 382
 383     return;
 384 }
 385
 386 sub _aggregate_parallel {
 387     my ( $self, $aggregate, @tests ) = @_;
 388
 389     my $jobs = $self->jobs;
 390     my $mux  = TAP::Parser::Multiplexer->new;
 391
 392     RESULT: {
 393
 394         # Keep multiplexer topped up
 395         while ( @tests && $mux->parsers < $jobs ) {
 396             my $test = shift @tests;
 397             my ( $parser, $session ) = $self->make_parser($test);
 398             $mux->add( $parser, [ $session, $test ] );
 399         }
 400
 401         if ( my ( $parser, $stash, $result ) = $mux->next ) {
 402             my ( $session, $test ) = @$stash;
 403             if ( defined $result ) {
 404                 $session->result($result);
 405                 exit 1 if $result->is_bailout;
 406             }
 407             else {
 408
 409                 # End of parser. Automatically removed from the mux.
 410                 $self->finish_parser( $parser, $session );
 411                 $self->_after_test( $aggregate, $test, $parser );
 412             }
 413             redo RESULT;
 414         }
 415     }
 416
 417     return;
 418 }
 419
 420 sub _aggregate_single {
 421     my ( $self, $aggregate, @tests ) = @_;
 422
 423     for my $test (@tests) {
 424         my ( $parser, $session ) = $self->make_parser($test);
 425
 426         while ( defined( my $result = $parser->next ) ) {
 427             $session->result($result);
 428             if ( $result->is_bailout ) {
 429
 430                 # Keep reading until input is exhausted in the hope
 431                 # of allowing any pending diagnostics to show up.
 432                 1 while $parser->next;
 433                 exit 1;
 434             }
 435         }
 436
 437         $self->finish_parser( $parser, $session );
 438         $self->_after_test( $aggregate, $test, $parser );
 439     }
 440
 441     return;
 442 }
 443
 444 =head3 C<aggregate_tests>
 445
 446   $harness->aggregate_tests( $aggregate, @tests );
 447
 448 Run the named tests and display a summary of result. Tests will be run
 449 in the order found.
 450
 451 Test results will be added to the supplied L<TAP::Parser::Aggregator>.
 452 C<aggregate_tests> may be called multiple times to run several sets of
 453 tests. Multiple C<Test::Harness> instances may be used to pass results
 454 to a single aggregator so that different parts of a complex test suite
 455 may be run using different C<TAP::Harness> settings. This is useful, for
 456 example, in the case where some tests should run in parallel but others
 457 are unsuitable for parallel execution.
 458
 459     my $formatter = TAP::Formatter::Console->new;
 460     my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
 461     my $par_harness = TAP::Harness->new( { formatter => $formatter,
 462                                            jobs => 9 } );
 463     my $aggregator = TAP::Parser::Aggregator->new;
 464
 465     $aggregator->start();
 466     $ser_harness->aggregate_tests( $aggregator, @ser_tests );
 467     $par_harness->aggregate_tests( $aggregator, @par_tests );
 468     $aggregator->stop();
 469     $formatter->summary( $aggregator );
 470
 471 Note that for simpler testing requirements it will often be possible to
 472 replace the above code with a single call to C<runtests>.
 473
 474 Each elements of the @tests array is either
 475
 476 =over
 477
 478 =item * the file name of a test script to run
 479
 480 =item * a reference to a [ file name, display name ]
 481
 482 =back
 483
 484 When you supply a separate display name it becomes possible to run a
 485 test more than once; the display name is effectively the alias by which
 486 the test is known inside the harness. The harness doesn't care if it
 487 runs the same script more than once when each invocation uses a
 488 different name.
 489
 490 =cut
 491
 492 sub aggregate_tests {
 493     my ( $self, $aggregate, @tests ) = @_;
 494
 495     my $jobs = $self->jobs;
 496
 497     my @expanded = map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @tests;
 498
 499     # #12458
 500     local $ENV{HARNESS_IS_VERBOSE} = 1
 501       if $self->formatter->verbosity > 0;
 502
 503     # Formatter gets only names
 504     $self->formatter->prepare( map { $_->[1] } @expanded );
 505
 506     if ( $self->jobs > 1 ) {
 507         if ( $self->fork ) {
 508             $self->_aggregate_forked( $aggregate, @expanded );
 509         }
 510         else {
 511             $self->_aggregate_parallel( $aggregate, @expanded );
 512         }
 513     }
 514     else {
 515         $self->_aggregate_single( $aggregate, @expanded );
 516     }
 517
 518     return;
 519 }
 520
 521 =head3 C<jobs>
 522
 523 Returns the number of concurrent test runs the harness is handling. For the default
 524 harness this value is always 1. A parallel harness such as L<TAP::Harness::Parallel>
 525 will override this to return the number of jobs it is handling.
 526
 527 =head3 C<fork>
 528
 529 If true the harness will attempt to fork and run the parser for each
 530 test in a separate process. Currently this option requires
 531 L<Parallel::Iterator> to be installed.
 532
 533 =cut
 534
 535 ##############################################################################
 536
 537 =head1 SUBCLASSING
 538
 539 C<TAP::Harness> is designed to be (mostly) easy to subclass.  If you don't
 540 like how a particular feature functions, just override the desired methods.
 541
 542 =head2 Methods
 543
 544 TODO: This is out of date
 545
 546 The following methods are ones you may wish to override if you want to
 547 subclass C<TAP::Harness>.
 548
 549 =head3 C<summary>
 550
 551   $harness->summary( \%args );
 552
 553 C<summary> prints the summary report after all tests are run.  The argument is
 554 a hashref with the following keys:
 555
 556 =over 4
 557
 558 =item * C<start>
 559
 560 This is created with C<< Benchmark->new >> and it the time the tests started.
 561 You can print a useful summary time, if desired, with:
 562
 563   $self->output(timestr( timediff( Benchmark->new, $start_time ), 'nop' ));
 564
 565 =item * C<tests>
 566
 567 This is an array reference of all test names.  To get the L<TAP::Parser>
 568 object for individual tests:
 569
 570  my $aggregate = $args->{aggregate};
 571  my $tests     = $args->{tests};
 572
 573  for my $name ( @$tests ) {
 574      my ($parser) = $aggregate->parsers($test);
 575      ... do something with $parser
 576  }
 577
 578 This is a bit clunky and will be cleaned up in a later release.
 579
 580 =back
 581
 582 =cut
 583
 584 sub _get_parser_args {
 585     my ( $self, $test ) = @_;
 586     my $test_prog = $test->[0];
 587     my %args      = ();
 588     my @switches;
 589     @switches = $self->lib if $self->lib;
 590     push @switches => $self->switches if $self->switches;
 591     $args{switches} = \@switches;
 592     $args{spool}    = $self->_open_spool($test_prog);
 593     $args{merge}    = $self->merge;
 594     $args{exec}     = $self->exec;
 595
 596     if ( my $exec = $self->exec ) {
 597         $args{exec} = [ @$exec, $test_prog ];
 598     }
 599     else {
 600         $args{source} = $test_prog;
 601     }
 602
 603     if ( defined( my $test_args = $self->test_args ) ) {
 604         $args{test_args} = $test_args;
 605     }
 606
 607     return \%args;
 608 }
 609
 610 =head3 C<make_parser>
 611
 612 Make a new parser and display formatter session. Typically used and/or
 613 overridden in subclasses.
 614
 615     my ( $parser, $session ) = $harness->make_parser;
 616
 617
 618 =cut
 619
 620 sub make_parser {
 621     my ( $self, $test ) = @_;
 622
 623     my $args = $self->_get_parser_args($test);
 624     $self->_make_callback( 'parser_args', $args, $test );
 625     my $parser = TAP::Parser->new($args);
 626
 627     $self->_make_callback( 'made_parser', $parser, $test );
 628     my $session = $self->formatter->open_test( $test->[1], $parser );
 629
 630     return ( $parser, $session );
 631 }
 632
 633 =head3 C<finish_parser>
 634
 635 Terminate use of a parser. Typically used and/or overridden in
 636 subclasses. The parser isn't destroyed as a result of this.
 637
 638 =cut
 639
 640 sub finish_parser {
 641     my ( $self, $parser, $session ) = @_;
 642
 643     $session->close_test;
 644     $self->_close_spool($parser);
 645
 646     return $parser;
 647 }
 648
 649 sub _open_spool {
 650     my $self = shift;
 651     my $test = shift;
 652
 653     if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
 654
 655         my $spool = File::Spec->catfile( $spool_dir, $test );
 656
 657         # Make the directory
 658         my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
 659         my $path = File::Spec->catpath( $vol, $dir, '' );
 660         eval { mkpath($path) };
 661         $self->_croak($@) if $@;
 662
 663         my $spool_handle = IO::Handle->new;
 664         open( $spool_handle, ">$spool" )
 665           or $self->_croak(" Can't write $spool ( $! ) ");
 666
 667         return $spool_handle;
 668     }
 669
 670     return;
 671 }
 672
 673 sub _close_spool {
 674     my $self = shift;
 675     my ($parser) = @_;
 676
 677     if ( my $spool_handle = $parser->delete_spool ) {
 678         close($spool_handle)
 679           or $self->_croak(" Error closing TAP spool file( $! ) \n ");
 680     }
 681
 682     return;
 683 }
 684
 685 sub _croak {
 686     my ( $self, $message ) = @_;
 687     unless ($message) {
 688         $message = $self->_error;
 689     }
 690     $self->SUPER::_croak($message);
 691
 692     return;
 693 }
 694
 695 =head1 REPLACING
 696
 697 If you like the C<prove> utility and L<TAP::Parser> but you want your
 698 own harness, all you need to do is write one and provide C<new> and
 699 C<runtests> methods. Then you can use the C<prove> utility like so:
 700
 701  prove --harness My::Test::Harness
 702
 703 Note that while C<prove> accepts a list of tests (or things to be
 704 tested), C<new> has a fairly rich set of arguments. You'll probably want
 705 to read over this code carefully to see how all of them are being used.
 706
 707 =head1 SEE ALSO
 708
 709 L<Test::Harness>
 710
 711 =cut
 712
 713 1;
 714
 715 # vim:ts=4:sw=4:et:sta