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