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.06
  26
  27 =cut
  28
  29 $VERSION = '3.06';
  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     $self->aggregate_tests( $aggregate, @tests );
 334     $self->formatter->summary($aggregate);
 335     $self->_make_callback( 'after_runtests', $aggregate );
 336
 337     return $aggregate;
 338 }
 339
 340 =head3 C<aggregate_tests>
 341
 342   $harness->aggregate_tests( $aggregate, @tests );
 343
 344 Tests will be run in the order found.
 345
 346 =cut
 347
 348 sub _after_test {
 349     my ( $self, $aggregate, $test, $parser ) = @_;
 350
 351     $self->_make_callback( 'after_test', $test, $parser );
 352     $aggregate->add( $test->[1], $parser );
 353 }
 354
 355 sub _aggregate_forked {
 356     my ( $self, $aggregate, @tests ) = @_;
 357
 358     eval { require Parallel::Iterator };
 359
 360     croak "Parallel::Iterator required for --fork option ($@)"
 361       if $@;
 362
 363     my $iter = Parallel::Iterator::iterate(
 364         { workers => $self->jobs || 0 },
 365         sub {
 366             my ( $id, $test ) = @_;
 367
 368             my ( $parser, $session ) = $self->make_parser($test);
 369
 370             while ( defined( my $result = $parser->next ) ) {
 371                 exit 1 if $result->is_bailout;
 372             }
 373
 374             $self->finish_parser( $parser, $session );
 375
 376             # Can't serialise coderefs...
 377             delete $parser->{_iter};
 378             delete $parser->{_stream};
 379             delete $parser->{_grammar};
 380             return $parser;
 381         },
 382         \@tests
 383     );
 384
 385     while ( my ( $id, $parser ) = $iter->() ) {
 386         $self->_after_test( $aggregate, $tests[$id], $parser );
 387     }
 388
 389     return;
 390 }
 391
 392 sub _aggregate_parallel {
 393     my ( $self, $aggregate, @tests ) = @_;
 394
 395     my $jobs = $self->jobs;
 396     my $mux  = TAP::Parser::Multiplexer->new;
 397
 398     RESULT: {
 399
 400         # Keep multiplexer topped up
 401         while ( @tests && $mux->parsers < $jobs ) {
 402             my $test = shift @tests;
 403             my ( $parser, $session ) = $self->make_parser($test);
 404             $mux->add( $parser, [ $session, $test ] );
 405         }
 406
 407         if ( my ( $parser, $stash, $result ) = $mux->next ) {
 408             my ( $session, $test ) = @$stash;
 409             if ( defined $result ) {
 410                 $session->result($result);
 411                 exit 1 if $result->is_bailout;
 412             }
 413             else {
 414
 415                 # End of parser. Automatically removed from the mux.
 416                 $self->finish_parser( $parser, $session );
 417                 $self->_after_test( $aggregate, $test, $parser );
 418             }
 419             redo RESULT;
 420         }
 421     }
 422
 423     return;
 424 }
 425
 426 sub _aggregate_single {
 427     my ( $self, $aggregate, @tests ) = @_;
 428
 429     for my $test (@tests) {
 430         my ( $parser, $session ) = $self->make_parser($test);
 431
 432         while ( defined( my $result = $parser->next ) ) {
 433             $session->result($result);
 434             if ( $result->is_bailout ) {
 435
 436                 # Keep reading until input is exhausted in the hope
 437                 # of allowing any pending diagnostics to show up.
 438                 1 while $parser->next;
 439                 exit 1;
 440             }
 441         }
 442
 443         $self->finish_parser( $parser, $session );
 444         $self->_after_test( $aggregate, $test, $parser );
 445     }
 446
 447     return;
 448 }
 449
 450 sub aggregate_tests {
 451     my ( $self, $aggregate, @tests ) = @_;
 452
 453     my $jobs = $self->jobs;
 454
 455     my @expanded = map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @tests;
 456
 457     # Formatter gets only names
 458     $self->formatter->prepare( map { $_->[1] } @expanded );
 459     $aggregate->start;
 460
 461     if ( $self->jobs > 1 ) {
 462         if ( $self->fork ) {
 463             $self->_aggregate_forked( $aggregate, @expanded );
 464         }
 465         else {
 466             $self->_aggregate_parallel( $aggregate, @expanded );
 467         }
 468     }
 469     else {
 470         $self->_aggregate_single( $aggregate, @expanded );
 471     }
 472
 473     $aggregate->stop;
 474
 475     return;
 476 }
 477
 478 =head3 C<jobs>
 479
 480 Returns the number of concurrent test runs the harness is handling. For the default
 481 harness this value is always 1. A parallel harness such as L<TAP::Harness::Parallel>
 482 will override this to return the number of jobs it is handling.
 483
 484 =head3 C<fork>
 485
 486 If true the harness will attempt to fork and run the parser for each
 487 test in a separate process. Currently this option requires
 488 L<Parallel::Iterator> to be installed.
 489
 490 =cut
 491
 492 ##############################################################################
 493
 494 =head1 SUBCLASSING
 495
 496 C<TAP::Harness> is designed to be (mostly) easy to subclass.  If you don't
 497 like how a particular feature functions, just override the desired methods.
 498
 499 =head2 Methods
 500
 501 TODO: This is out of date
 502
 503 The following methods are ones you may wish to override if you want to
 504 subclass C<TAP::Harness>.
 505
 506 =head3 C<summary>
 507
 508   $harness->summary( \%args );
 509
 510 C<summary> prints the summary report after all tests are run.  The argument is
 511 a hashref with the following keys:
 512
 513 =over 4
 514
 515 =item * C<start>
 516
 517 This is created with C<< Benchmark->new >> and it the time the tests started.
 518 You can print a useful summary time, if desired, with:
 519
 520   $self->output(timestr( timediff( Benchmark->new, $start_time ), 'nop' ));
 521
 522 =item * C<tests>
 523
 524 This is an array reference of all test names.  To get the L<TAP::Parser>
 525 object for individual tests:
 526
 527  my $aggregate = $args->{aggregate};
 528  my $tests     = $args->{tests};
 529
 530  for my $name ( @$tests ) {
 531      my ($parser) = $aggregate->parsers($test);
 532      ... do something with $parser
 533  }
 534
 535 This is a bit clunky and will be cleaned up in a later release.
 536
 537 =back
 538
 539 =cut
 540
 541 sub _get_parser_args {
 542     my ( $self, $test ) = @_;
 543     my $test_prog = $test->[0];
 544     my %args      = ();
 545     my @switches;
 546     @switches = $self->lib if $self->lib;
 547     push @switches => $self->switches if $self->switches;
 548     $args{switches} = \@switches;
 549     $args{spool}    = $self->_open_spool($test_prog);
 550     $args{merge}    = $self->merge;
 551     $args{exec}     = $self->exec;
 552
 553     if ( my $exec = $self->exec ) {
 554         $args{exec} = [ @$exec, $test_prog ];
 555     }
 556     else {
 557         $args{source} = $test_prog;
 558     }
 559
 560     if ( defined( my $test_args = $self->test_args ) ) {
 561         $args{test_args} = $test_args;
 562     }
 563
 564     return \%args;
 565 }
 566
 567 =head3 C<make_parser>
 568
 569 Make a new parser and display formatter session. Typically used and/or
 570 overridden in subclasses.
 571
 572     my ( $parser, $session ) = $harness->make_parser;
 573
 574
 575 =cut
 576
 577 sub make_parser {
 578     my ( $self, $test ) = @_;
 579
 580     my $args = $self->_get_parser_args($test);
 581     $self->_make_callback( 'parser_args', $args, $test );
 582     my $parser = TAP::Parser->new($args);
 583
 584     $self->_make_callback( 'made_parser', $parser, $test );
 585     my $session = $self->formatter->open_test( $test->[1], $parser );
 586
 587     return ( $parser, $session );
 588 }
 589
 590 =head3 C<finish_parser>
 591
 592 Terminate use of a parser. Typically used and/or overridden in
 593 subclasses. The parser isn't destroyed as a result of this.
 594
 595 =cut
 596
 597 sub finish_parser {
 598     my ( $self, $parser, $session ) = @_;
 599
 600     $session->close_test;
 601     $self->_close_spool($parser);
 602
 603     return $parser;
 604 }
 605
 606 sub _open_spool {
 607     my $self = shift;
 608     my $test = shift;
 609
 610     if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
 611
 612         my $spool = File::Spec->catfile( $spool_dir, $test );
 613
 614         # Make the directory
 615         my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
 616         my $path = File::Spec->catpath( $vol, $dir, '' );
 617         eval { mkpath($path) };
 618         $self->_croak($@) if $@;
 619
 620         my $spool_handle = IO::Handle->new;
 621         open( $spool_handle, ">$spool" )
 622           or $self->_croak(" Can't write $spool ( $! ) ");
 623
 624         return $spool_handle;
 625     }
 626
 627     return;
 628 }
 629
 630 sub _close_spool {
 631     my $self = shift;
 632     my ($parser) = @_;
 633
 634     if ( my $spool_handle = $parser->delete_spool ) {
 635         close($spool_handle)
 636           or $self->_croak(" Error closing TAP spool file( $! ) \n ");
 637     }
 638
 639     return;
 640 }
 641
 642 sub _croak {
 643     my ( $self, $message ) = @_;
 644     unless ($message) {
 645         $message = $self->_error;
 646     }
 647     $self->SUPER::_croak($message);
 648
 649     return;
 650 }
 651
 652 =head1 REPLACING
 653
 654 If you like the C<prove> utility and L<TAP::Parser> but you want your
 655 own harness, all you need to do is write one and provide C<new> and
 656 C<runtests> methods. Then you can use the C<prove> utility like so:
 657
 658  prove --harness My::Test::Harness
 659
 660 Note that while C<prove> accepts a list of tests (or things to be
 661 tested), C<new> has a fairly rich set of arguments. You'll probably want
 662 to read over this code carefully to see how all of them are being used.
 663
 664 =head1 SEE ALSO
 665
 666 L<Test::Harness>
 667
 668 =cut
 669
 670 1;
 671
 672 # vim:ts=4:sw=4:et:sta