lib/App/Prove.pm

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