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.05
  19
  20 =cut
  21
  22 $VERSION = '3.05';
  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
  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             'c'           => \$self->{color},
 194             'harness=s'   => \$self->{harness},
 195             'formatter=s' => \$self->{formatter},
 196             'r|recurse'   => \$self->{recurse},
 197             'reverse'     => \$self->{backwards},
 198             'fork'        => \$self->{fork},
 199             'p|parse'     => \$self->{parse},
 200             'q|quiet'     => \$self->{quiet},
 201             'Q|QUIET'     => \$self->{really_quiet},
 202             'e|exec=s'    => \$self->{exec},
 203             'm|merge'     => \$self->{merge},
 204             'I=s@'        => $self->{includes},
 205             'M=s@'        => $self->{modules},
 206             'P=s@'        => $self->{plugins},
 207             'state=s@'    => $self->{state},
 208             'directives'  => \$self->{directives},
 209             'h|help|?'    => \$self->{show_help},
 210             'H|man'       => \$self->{show_man},
 211             'V|version'   => \$self->{show_version},
 212             'a|archive=s' => \$self->{archive},
 213             'j|jobs=i'    => \$self->{jobs},
 214             'timer'       => \$self->{timer},
 215             'T'           => \$self->{taint_fail},
 216             't'           => \$self->{taint_warn},
 217             'W'           => \$self->{warnings_fail},
 218             'w'           => \$self->{warnings_warn},
 219         ) or croak('Unable to continue');
 220
 221         # Stash the remainder of argv for later
 222         $self->{argv} = [@ARGV];
 223     }
 224
 225     return;
 226 }
 227
 228 sub _first_pos {
 229     my $want = shift;
 230     for ( 0 .. $#_ ) {
 231         return $_ if $_[$_] eq $want;
 232     }
 233     return;
 234 }
 235
 236 sub _exit { exit( $_[1] || 0 ) }
 237
 238 sub _help {
 239     my ( $self, $verbosity ) = @_;
 240
 241     eval('use Pod::Usage 1.12 ()');
 242     if ( my $err = $@ ) {
 243         die 'Please install Pod::Usage for the --help option '
 244           . '(or try `perldoc prove`.)'
 245           . "\n ($@)";
 246     }
 247
 248     Pod::Usage::pod2usage( { -verbose => $verbosity } );
 249
 250     return;
 251 }
 252
 253 sub _color_default {
 254     my $self = shift;
 255
 256     return -t STDOUT && !IS_WIN32;
 257 }
 258
 259 sub _get_args {
 260     my $self = shift;
 261
 262     my %args;
 263
 264     if ( defined $self->color ? $self->color : $self->_color_default ) {
 265         $args{color} = 1;
 266     }
 267
 268     if ( $self->archive ) {
 269         $self->require_harness( archive => 'TAP::Harness::Archive' );
 270         $args{archive} = $self->archive;
 271     }
 272
 273     if ( my $jobs = $self->jobs ) {
 274         $args{jobs} = $jobs;
 275     }
 276
 277     if ( my $fork = $self->fork ) {
 278         $args{fork} = $fork;
 279     }
 280
 281     if ( my $harness_opt = $self->harness ) {
 282         $self->require_harness( harness => $harness_opt );
 283     }
 284
 285     if ( my $formatter = $self->formatter ) {
 286         $args{formatter_class} = $formatter;
 287     }
 288
 289     if ( $self->taint_fail && $self->taint_warn ) {
 290         die '-t and -T are mutually exclusive';
 291     }
 292
 293     if ( $self->warnings_fail && $self->warnings_warn ) {
 294         die '-w and -W are mutually exclusive';
 295     }
 296
 297     for my $a (qw( lib switches )) {
 298         my $method = "_get_$a";
 299         my $val    = $self->$method();
 300         $args{$a} = $val if defined $val;
 301     }
 302
 303     # Handle verbose, quiet, really_quiet flags
 304     my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
 305
 306     my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
 307       keys %verb_map;
 308
 309     die "Only one of verbose, quiet or really_quiet should be specified\n"
 310       if @verb_adj > 1;
 311
 312     $args{verbosity} = shift @verb_adj || 0;
 313
 314     for my $a (qw( merge failures timer directives )) {
 315         $args{$a} = 1 if $self->$a();
 316     }
 317
 318     $args{errors} = 1 if $self->parse;
 319
 320     # defined but zero-length exec runs test files as binaries
 321     $args{exec} = [ split( /\s+/, $self->exec ) ]
 322       if ( defined( $self->exec ) );
 323
 324     if ( defined( my $test_args = $self->test_args ) ) {
 325         $args{test_args} = $test_args;
 326     }
 327
 328     return ( \%args, $self->{harness_class} );
 329 }
 330
 331 sub _find_module {
 332     my ( $self, $class, @search ) = @_;
 333
 334     croak "Bad module name $class"
 335       unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
 336
 337     for my $pfx (@search) {
 338         my $name = join( '::', $pfx, $class );
 339         print "$name\n";
 340         eval "require $name";
 341         return $name unless $@;
 342     }
 343
 344     eval "require $class";
 345     return $class unless $@;
 346     return;
 347 }
 348
 349 sub _load_extension {
 350     my ( $self, $class, @search ) = @_;
 351
 352     my @args = ();
 353     if ( $class =~ /^(.*?)=(.*)/ ) {
 354         $class = $1;
 355         @args = split( /,/, $2 );
 356     }
 357
 358     if ( my $name = $self->_find_module( $class, @search ) ) {
 359         $name->import(@args);
 360     }
 361     else {
 362         croak "Can't load module $class";
 363     }
 364 }
 365
 366 sub _load_extensions {
 367     my ( $self, $ext, @search ) = @_;
 368     $self->_load_extension( $_, @search ) for @$ext;
 369 }
 370
 371 =head3 C<run>
 372
 373 Perform whatever actions the command line args specified. The C<prove>
 374 command line tool consists of the following code:
 375
 376     use App::Prove;
 377
 378     my $app = App::Prove->new;
 379     $app->process_args(@ARGV);
 380     $app->run;
 381
 382 =cut
 383
 384 sub run {
 385     my $self = shift;
 386
 387     if ( $self->show_help ) {
 388         $self->_help(1);
 389     }
 390     elsif ( $self->show_man ) {
 391         $self->_help(2);
 392     }
 393     elsif ( $self->show_version ) {
 394         $self->print_version;
 395     }
 396     else {
 397
 398         $self->_load_extensions( $self->modules );
 399         $self->_load_extensions( $self->plugins, PLUGINS );
 400
 401         my $state = $self->{_state};
 402         if ( defined( my $state_switch = $self->state ) ) {
 403             $state->apply_switch(@$state_switch);
 404         }
 405
 406         my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
 407
 408         $self->_shuffle(@tests) if $self->shuffle;
 409         @tests = reverse @tests if $self->backwards;
 410
 411         $self->_runtests( $self->_get_args, @tests );
 412     }
 413
 414     return;
 415 }
 416
 417 sub _runtests {
 418     my ( $self, $args, $harness_class, @tests ) = @_;
 419     my $harness = $harness_class->new($args);
 420
 421     $harness->callback(
 422         after_test => sub {
 423             $self->{_state}->observe_test(@_);
 424         }
 425     );
 426
 427     my $aggregator = $harness->runtests(@tests);
 428
 429     $self->_exit( $aggregator->has_problems ? 1 : 0 );
 430
 431     return;
 432 }
 433
 434 sub _get_switches {
 435     my $self = shift;
 436     my @switches;
 437
 438     # notes that -T or -t must be at the front of the switches!
 439     if ( $self->taint_fail ) {
 440         push @switches, '-T';
 441     }
 442     elsif ( $self->taint_warn ) {
 443         push @switches, '-t';
 444     }
 445     if ( $self->warnings_fail ) {
 446         push @switches, '-W';
 447     }
 448     elsif ( $self->warnings_warn ) {
 449         push @switches, '-w';
 450     }
 451
 452     return @switches ? \@switches : ();
 453 }
 454
 455 sub _get_lib {
 456     my $self = shift;
 457     my @libs;
 458     if ( $self->lib ) {
 459         push @libs, 'lib';
 460     }
 461     if ( $self->blib ) {
 462         push @libs, 'blib/lib', 'blib/arch';
 463     }
 464     if ( @{ $self->includes } ) {
 465         push @libs, @{ $self->includes };
 466     }
 467
 468     #24926
 469     @libs = map { File::Spec->rel2abs($_) } @libs;
 470
 471     # Huh?
 472     return @libs ? \@libs : ();
 473 }
 474
 475 sub _shuffle {
 476     my $self = shift;
 477
 478     # Fisher-Yates shuffle
 479     my $i = @_;
 480     while ($i) {
 481         my $j = rand $i--;
 482         @_[ $i, $j ] = @_[ $j, $i ];
 483     }
 484     return;
 485 }
 486
 487 =head3 C<require_harness>
 488
 489 Load a harness replacement class.
 490
 491   $prove->require_harness($for => $class_name);
 492
 493 =cut
 494
 495 sub require_harness {
 496     my ( $self, $for, $class ) = @_;
 497
 498     eval("require $class");
 499     die "$class is required to use the --$for feature: $@" if $@;
 500
 501     $self->{harness_class} = $class;
 502
 503     return;
 504 }
 505
 506 =head3 C<print_version>
 507
 508 Display the version numbers of the loaded L<TAP::Harness> and the
 509 current Perl.
 510
 511 =cut
 512
 513 sub print_version {
 514     my $self = shift;
 515     printf(
 516         "TAP::Harness v%s and Perl v%vd\n",
 517         $TAP::Harness::VERSION, $^V
 518     );
 519
 520     return;
 521 }
 522
 523 1;
 524
 525 # vim:ts=4:sw=4:et:sta
 526
 527 __END__
 528
 529 =head2 Attributes
 530
 531 After command line parsing the following attributes reflect the values
 532 of the corresponding command line switches. They may be altered before
 533 calling C<run>.
 534
 535 =over
 536
 537 =item C<archive>
 538
 539 =item C<argv>
 540
 541 =item C<backwards>
 542
 543 =item C<blib>
 544
 545 =item C<color>
 546
 547 =item C<directives>
 548
 549 =item C<exec>
 550
 551 =item C<failures>
 552
 553 =item C<fork>
 554
 555 =item C<formatter>
 556
 557 =item C<harness>
 558
 559 =item C<includes>
 560
 561 =item C<jobs>
 562
 563 =item C<lib>
 564
 565 =item C<merge>
 566
 567 =item C<modules>
 568
 569 =item C<parse>
 570
 571 =item C<plugins>
 572
 573 =item C<quiet>
 574
 575 =item C<really_quiet>
 576
 577 =item C<recurse>
 578
 579 =item C<show_help>
 580
 581 =item C<show_man>
 582
 583 =item C<show_version>
 584
 585 =item C<shuffle>
 586
 587 =item C<state>
 588
 589 =item C<taint_fail>
 590
 591 =item C<taint_warn>
 592
 593 =item C<test_args>
 594
 595 =item C<timer>
 596
 597 =item C<verbose>
 598
 599 =item C<warnings_fail>
 600
 601 =item C<warnings_warn>
 602
 603 =back