ext/Test/Harness/lib/App/Prove.pm

   1 package App::Prove;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA);
   5
   6 use TAP::Object ();
   7 use TAP::Harness;
   8 use TAP::Parser::Utils qw( split_shell );
   9 use File::Spec;
  10 use Getopt::Long;
  11 use App::Prove::State;
  12 use Carp;
  13
  14 @ISA = qw(TAP::Object);
  15
  16 =head1 NAME
  17
  18 App::Prove - Implements the C<prove> command.
  19
  20 =head1 VERSION
  21
  22 Version 3.14
  23
  24 =cut
  25
  26 $VERSION = '3.14';
  27
  28 =head1 DESCRIPTION
  29
  30 L<Test::Harness> provides a command, C<prove>, which runs a TAP based
  31 test suite and prints a report. The C<prove> command is a minimal
  32 wrapper around an instance of this module.
  33
  34 =head1 SYNOPSIS
  35
  36     use App::Prove;
  37
  38     my $app = App::Prove->new;
  39     $app->process_args(@ARGV);
  40     $app->run;
  41
  42 =cut
  43
  44 use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
  45 use constant IS_VMS => $^O eq 'VMS';
  46 use constant IS_UNIXY => !( IS_VMS || IS_WIN32 );
  47
  48 use constant STATE_FILE => IS_UNIXY ? '.prove'   : '_prove';
  49 use constant RC_FILE    => IS_UNIXY ? '.proverc' : '_proverc';
  50
  51 use constant PLUGINS => 'App::Prove::Plugin';
  52
  53 my @ATTR;
  54
  55 BEGIN {
  56     @ATTR = qw(
  57       archive argv blib show_count color directives exec failures fork
  58       formatter harness includes modules plugins jobs lib merge parse quiet
  59       really_quiet recurse backwards shuffle taint_fail taint_warn timer
  60       verbose warnings_fail warnings_warn show_help show_man show_version
  61       test_args state dry extension ignore_exit rules state_manager
  62     );
  63     for my $attr (@ATTR) {
  64         no strict 'refs';
  65         *$attr = sub {
  66             my $self = shift;
  67             $self->{$attr} = shift if @_;
  68             return $self->{$attr};
  69         };
  70     }
  71 }
  72
  73 =head1 METHODS
  74
  75 =head2 Class Methods
  76
  77 =head3 C<new>
  78
  79 Create a new C<App::Prove>. Optionally a hash ref of attribute
  80 initializers may be passed.
  81
  82 =cut
  83
  84 # new() implementation supplied by TAP::Object
  85
  86 sub _initialize {
  87     my $self = shift;
  88     my $args = shift || {};
  89
  90     # setup defaults:
  91     for my $key (qw( argv rc_opts includes modules state plugins rules )) {
  92         $self->{$key} = [];
  93     }
  94     $self->{harness_class} = 'TAP::Harness';
  95
  96     for my $attr (@ATTR) {
  97         if ( exists $args->{$attr} ) {
  98
  99             # TODO: Some validation here
 100             $self->{$attr} = $args->{$attr};
 101         }
 102     }
 103
 104     my %env_provides_default = (
 105         HARNESS_TIMER => 'timer',
 106     );
 107
 108     while ( my ( $env, $attr ) = each %env_provides_default ) {
 109         $self->{$attr} = 1 if $ENV{$env};
 110     }
 111     $self->state_manager(
 112         $self->state_class->new( { store => STATE_FILE } ) );
 113
 114     return $self;
 115 }
 116
 117 =head3 C<state_class>
 118
 119 Returns the name of the class used for maintaining state.  This class should
 120 either subclass from C<App::Prove::State> or provide an identical interface.
 121
 122 =head3 C<state_manager>
 123
 124 Getter/setter for the an instane of the C<state_class>.
 125
 126 =cut
 127
 128 sub state_class {
 129     return 'App::Prove::State';
 130 }
 131
 132 =head3 C<add_rc_file>
 133
 134     $prove->add_rc_file('myproj/.proverc');
 135
 136 Called before C<process_args> to prepend the contents of an rc file to
 137 the options.
 138
 139 =cut
 140
 141 sub add_rc_file {
 142     my ( $self, $rc_file ) = @_;
 143
 144     local *RC;
 145     open RC, "<$rc_file" or croak "Can't read $rc_file ($!)";
 146     while ( defined( my $line = <RC> ) ) {
 147         push @{ $self->{rc_opts} }, grep $_ && $_ !~ /^#/,
 148           $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S*) }xg;
 149     }
 150     close RC;
 151 }
 152
 153 =head3 C<process_args>
 154
 155     $prove->process_args(@args);
 156
 157 Processes the command-line arguments. Attributes will be set
 158 appropriately. Any filenames may be found in the C<argv> attribute.
 159
 160 Dies on invalid arguments.
 161
 162 =cut
 163
 164 sub process_args {
 165     my $self = shift;
 166
 167     my @rc = RC_FILE;
 168     unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
 169
 170     # Preprocess meta-args.
 171     my @args;
 172     while ( defined( my $arg = shift ) ) {
 173         if ( $arg eq '--norc' ) {
 174             @rc = ();
 175         }
 176         elsif ( $arg eq '--rc' ) {
 177             defined( my $rc = shift )
 178               or croak "Missing argument to --rc";
 179             push @rc, $rc;
 180         }
 181         elsif ( $arg =~ m{^--rc=(.+)$} ) {
 182             push @rc, $1;
 183         }
 184         else {
 185             push @args, $arg;
 186         }
 187     }
 188
 189     # Everything after the arisdottle '::' gets passed as args to
 190     # test programs.
 191     if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
 192         my @test_args = splice @args, $stop_at;
 193         shift @test_args;
 194         $self->{test_args} = \@test_args;
 195     }
 196
 197     # Grab options from RC files
 198     $self->add_rc_file($_) for grep -f, @rc;
 199     unshift @args, @{ $self->{rc_opts} };
 200
 201     if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
 202         die "Long options should be written with two dashes: ",
 203           join( ', ', @bad ), "\n";
 204     }
 205
 206     # And finally...
 207
 208     {
 209         local @ARGV = @args;
 210         Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
 211
 212         # Don't add coderefs to GetOptions
 213         GetOptions(
 214             'v|verbose'   => \$self->{verbose},
 215             'f|failures'  => \$self->{failures},
 216             'l|lib'       => \$self->{lib},
 217             'b|blib'      => \$self->{blib},
 218             's|shuffle'   => \$self->{shuffle},
 219             'color!'      => \$self->{color},
 220             'colour!'     => \$self->{color},
 221             'count!'      => \$self->{show_count},
 222             'c'           => \$self->{color},
 223             'D|dry'       => \$self->{dry},
 224             'ext=s'       => \$self->{extension},
 225             'harness=s'   => \$self->{harness},
 226             'ignore-exit' => \$self->{ignore_exit},
 227             'formatter=s' => \$self->{formatter},
 228             'r|recurse'   => \$self->{recurse},
 229             'reverse'     => \$self->{backwards},
 230             'fork'        => \$self->{fork},
 231             'p|parse'     => \$self->{parse},
 232             'q|quiet'     => \$self->{quiet},
 233             'Q|QUIET'     => \$self->{really_quiet},
 234             'e|exec=s'    => \$self->{exec},
 235             'm|merge'     => \$self->{merge},
 236             'I=s@'        => $self->{includes},
 237             'M=s@'        => $self->{modules},
 238             'P=s@'        => $self->{plugins},
 239             'state=s@'    => $self->{state},
 240             'directives'  => \$self->{directives},
 241             'h|help|?'    => \$self->{show_help},
 242             'H|man'       => \$self->{show_man},
 243             'V|version'   => \$self->{show_version},
 244             'a|archive=s' => \$self->{archive},
 245             'j|jobs=i'    => \$self->{jobs},
 246             'timer'       => \$self->{timer},
 247             'T'           => \$self->{taint_fail},
 248             't'           => \$self->{taint_warn},
 249             'W'           => \$self->{warnings_fail},
 250             'w'           => \$self->{warnings_warn},
 251             'rules=s@'    => $self->{rules},
 252         ) or croak('Unable to continue');
 253
 254         # Stash the remainder of argv for later
 255         $self->{argv} = [@ARGV];
 256     }
 257
 258     return;
 259 }
 260
 261 sub _first_pos {
 262     my $want = shift;
 263     for ( 0 .. $#_ ) {
 264         return $_ if $_[$_] eq $want;
 265     }
 266     return;
 267 }
 268
 269 sub _help {
 270     my ( $self, $verbosity ) = @_;
 271
 272     eval('use Pod::Usage 1.12 ()');
 273     if ( my $err = $@ ) {
 274         die 'Please install Pod::Usage for the --help option '
 275           . '(or try `perldoc prove`.)'
 276           . "\n ($@)";
 277     }
 278
 279     Pod::Usage::pod2usage( { -verbose => $verbosity } );
 280
 281     return;
 282 }
 283
 284 sub _color_default {
 285     my $self = shift;
 286
 287     return -t STDOUT && !IS_WIN32;
 288 }
 289
 290 sub _get_args {
 291     my $self = shift;
 292
 293     my %args;
 294
 295     if ( defined $self->color ? $self->color : $self->_color_default ) {
 296         $args{color} = 1;
 297     }
 298     if ( !defined $self->show_count ) {
 299         $args{show_count} = 1;
 300     }
 301     else {
 302         $args{show_count} = $self->show_count;
 303     }
 304
 305     if ( $self->archive ) {
 306         $self->require_harness( archive => 'TAP::Harness::Archive' );
 307         $args{archive} = $self->archive;
 308     }
 309
 310     if ( my $jobs = $self->jobs ) {
 311         $args{jobs} = $jobs;
 312     }
 313
 314     if ( my $fork = $self->fork ) {
 315         $args{fork} = $fork;
 316     }
 317
 318     if ( my $harness_opt = $self->harness ) {
 319         $self->require_harness( harness => $harness_opt );
 320     }
 321
 322     if ( my $formatter = $self->formatter ) {
 323         $args{formatter_class} = $formatter;
 324     }
 325
 326     if ( $self->ignore_exit ) {
 327         $args{ignore_exit} = 1;
 328     }
 329
 330     if ( $self->taint_fail && $self->taint_warn ) {
 331         die '-t and -T are mutually exclusive';
 332     }
 333
 334     if ( $self->warnings_fail && $self->warnings_warn ) {
 335         die '-w and -W are mutually exclusive';
 336     }
 337
 338     for my $a (qw( lib switches )) {
 339         my $method = "_get_$a";
 340         my $val    = $self->$method();
 341         $args{$a} = $val if defined $val;
 342     }
 343
 344     # Handle verbose, quiet, really_quiet flags
 345     my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
 346
 347     my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
 348       keys %verb_map;
 349
 350     die "Only one of verbose, quiet or really_quiet should be specified\n"
 351       if @verb_adj > 1;
 352
 353     $args{verbosity} = shift @verb_adj || 0;
 354
 355     for my $a (qw( merge failures timer directives )) {
 356         $args{$a} = 1 if $self->$a();
 357     }
 358
 359     $args{errors} = 1 if $self->parse;
 360
 361     # defined but zero-length exec runs test files as binaries
 362     $args{exec} = [ split( /\s+/, $self->exec ) ]
 363       if ( defined( $self->exec ) );
 364
 365     if ( defined( my $test_args = $self->test_args ) ) {
 366         $args{test_args} = $test_args;
 367     }
 368
 369     if ( @{ $self->rules } ) {
 370         my @rules;
 371         for ( @{ $self->rules } ) {
 372             if (/^par=(.*)/) {
 373                 push @rules, $1;
 374             }
 375             elsif (/^seq=(.*)/) {
 376                 push @rules, { seq => $1 };
 377             }
 378         }
 379         $args{rules} = { par => [@rules] };
 380     }
 381
 382     return ( \%args, $self->{harness_class} );
 383 }
 384
 385 sub _find_module {
 386     my ( $self, $class, @search ) = @_;
 387
 388     croak "Bad module name $class"
 389       unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
 390
 391     for my $pfx (@search) {
 392         my $name = join( '::', $pfx, $class );
 393         eval "require $name";
 394         return $name unless $@;
 395     }
 396
 397     eval "require $class";
 398     return $class unless $@;
 399     return;
 400 }
 401
 402 sub _load_extension {
 403     my ( $self, $class, @search ) = @_;
 404
 405     my @args = ();
 406     if ( $class =~ /^(.*?)=(.*)/ ) {
 407         $class = $1;
 408         @args = split( /,/, $2 );
 409     }
 410
 411     if ( my $name = $self->_find_module( $class, @search ) ) {
 412         $name->import(@args);
 413     }
 414     else {
 415         croak "Can't load module $class";
 416     }
 417 }
 418
 419 sub _load_extensions {
 420     my ( $self, $ext, @search ) = @_;
 421     $self->_load_extension( $_, @search ) for @$ext;
 422 }
 423
 424 =head3 C<run>
 425
 426 Perform whatever actions the command line args specified. The C<prove>
 427 command line tool consists of the following code:
 428
 429     use App::Prove;
 430
 431     my $app = App::Prove->new;
 432     $app->process_args(@ARGV);
 433     exit( $app->run ? 0 : 1 );  # if you need the exit code
 434
 435 =cut
 436
 437 sub run {
 438     my $self = shift;
 439
 440     if ( $self->show_help ) {
 441         $self->_help(1);
 442     }
 443     elsif ( $self->show_man ) {
 444         $self->_help(2);
 445     }
 446     elsif ( $self->show_version ) {
 447         $self->print_version;
 448     }
 449     elsif ( $self->dry ) {
 450         print "$_\n" for $self->_get_tests;
 451     }
 452     else {
 453
 454         $self->_load_extensions( $self->modules );
 455         $self->_load_extensions( $self->plugins, PLUGINS );
 456
 457         local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
 458
 459         return $self->_runtests( $self->_get_args, $self->_get_tests );
 460     }
 461
 462     return 1;
 463 }
 464
 465 sub _get_tests {
 466     my $self = shift;
 467
 468     my $state = $self->state_manager;
 469     my $ext   = $self->extension;
 470     $state->extension($ext) if defined $ext;
 471     if ( defined( my $state_switch = $self->state ) ) {
 472         $state->apply_switch(@$state_switch);
 473     }
 474
 475     my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
 476
 477     $self->_shuffle(@tests) if $self->shuffle;
 478     @tests = reverse @tests if $self->backwards;
 479
 480     return @tests;
 481 }
 482
 483 sub _runtests {
 484     my ( $self, $args, $harness_class, @tests ) = @_;
 485     my $harness = $harness_class->new($args);
 486
 487     my $state = $self->state_manager;
 488
 489     $harness->callback(
 490         after_test => sub {
 491             $state->observe_test(@_);
 492         }
 493     );
 494
 495     $harness->callback(
 496         after_runtests => sub {
 497             $state->commit(@_);
 498         }
 499     );
 500
 501     my $aggregator = $harness->runtests(@tests);
 502
 503     return !$aggregator->has_errors;
 504 }
 505
 506 sub _get_switches {
 507     my $self = shift;
 508     my @switches;
 509
 510     # notes that -T or -t must be at the front of the switches!
 511     if ( $self->taint_fail ) {
 512         push @switches, '-T';
 513     }
 514     elsif ( $self->taint_warn ) {
 515         push @switches, '-t';
 516     }
 517     if ( $self->warnings_fail ) {
 518         push @switches, '-W';
 519     }
 520     elsif ( $self->warnings_warn ) {
 521         push @switches, '-w';
 522     }
 523
 524     push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} );
 525
 526     return @switches ? \@switches : ();
 527 }
 528
 529 sub _get_lib {
 530     my $self = shift;
 531     my @libs;
 532     if ( $self->lib ) {
 533         push @libs, 'lib';
 534     }
 535     if ( $self->blib ) {
 536         push @libs, 'blib/lib', 'blib/arch';
 537     }
 538     if ( @{ $self->includes } ) {
 539         push @libs, @{ $self->includes };
 540     }
 541
 542     #24926
 543     @libs = map { File::Spec->rel2abs($_) } @libs;
 544
 545     # Huh?
 546     return @libs ? \@libs : ();
 547 }
 548
 549 sub _shuffle {
 550     my $self = shift;
 551
 552     # Fisher-Yates shuffle
 553     my $i = @_;
 554     while ($i) {
 555         my $j = rand $i--;
 556         @_[ $i, $j ] = @_[ $j, $i ];
 557     }
 558     return;
 559 }
 560
 561 =head3 C<require_harness>
 562
 563 Load a harness replacement class.
 564
 565   $prove->require_harness($for => $class_name);
 566
 567 =cut
 568
 569 sub require_harness {
 570     my ( $self, $for, $class ) = @_;
 571
 572     my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
 573
 574     # Emulate Perl's -MModule=arg1,arg2 behaviour
 575     $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
 576
 577     eval("use $class;");
 578     die "$class_name is required to use the --$for feature: $@" if $@;
 579
 580     $self->{harness_class} = $class_name;
 581
 582     return;
 583 }
 584
 585 =head3 C<print_version>
 586
 587 Display the version numbers of the loaded L<TAP::Harness> and the
 588 current Perl.
 589
 590 =cut
 591
 592 sub print_version {
 593     my $self = shift;
 594     printf(
 595         "TAP::Harness v%s and Perl v%vd\n",
 596         $TAP::Harness::VERSION, $^V
 597     );
 598
 599     return;
 600 }
 601
 602 1;
 603
 604 # vim:ts=4:sw=4:et:sta
 605
 606 __END__
 607
 608 =head2 Attributes
 609
 610 After command line parsing the following attributes reflect the values
 611 of the corresponding command line switches. They may be altered before
 612 calling C<run>.
 613
 614 =over
 615
 616 =item C<archive>
 617
 618 =item C<argv>
 619
 620 =item C<backwards>
 621
 622 =item C<blib>
 623
 624 =item C<color>
 625
 626 =item C<directives>
 627
 628 =item C<dry>
 629
 630 =item C<exec>
 631
 632 =item C<extension>
 633
 634 =item C<failures>
 635
 636 =item C<fork>
 637
 638 =item C<formatter>
 639
 640 =item C<harness>
 641
 642 =item C<ignore_exit>
 643
 644 =item C<includes>
 645
 646 =item C<jobs>
 647
 648 =item C<lib>
 649
 650 =item C<merge>
 651
 652 =item C<modules>
 653
 654 =item C<parse>
 655
 656 =item C<plugins>
 657
 658 =item C<quiet>
 659
 660 =item C<really_quiet>
 661
 662 =item C<recurse>
 663
 664 =item C<rules>
 665
 666 =item C<show_count>
 667
 668 =item C<show_help>
 669
 670 =item C<show_man>
 671
 672 =item C<show_version>
 673
 674 =item C<shuffle>
 675
 676 =item C<state>
 677
 678 =item C<taint_fail>
 679
 680 =item C<taint_warn>
 681
 682 =item C<test_args>
 683
 684 =item C<timer>
 685
 686 =item C<verbose>
 687
 688 =item C<warnings_fail>
 689
 690 =item C<warnings_warn>
 691
 692 =back