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