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