lib/App/Prove.pm

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