4 use vars qw($VERSION @ISA);
8 use TAP::Parser::Utils qw( split_shell );
11 use App::Prove::State;
16 App::Prove - Implements the C<prove> command.
28 L<Test::Harness> provides a command, C<prove>, which runs a TAP based
29 test suite and prints a report. The C<prove> command is a minimal
30 wrapper around an instance of this module.
36 my $app = App::Prove->new;
37 $app->process_args(@ARGV);
42 use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
43 use constant IS_VMS => $^O eq 'VMS';
44 use constant IS_UNIXY => !( IS_VMS || IS_WIN32 );
46 use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
47 use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
49 use constant PLUGINS => 'App::Prove::Plugin';
54 @ISA = qw(TAP::Object);
57 archive argv blib show_count color directives exec failures comments
58 formatter 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 show_version
61 state_class test_args state dry extension ignore_exit rules state_manager
64 __PACKAGE__->mk_methods(@ATTR);
73 Create a new C<App::Prove>. Optionally a hash ref of attribute
74 initializers may be passed.
78 # new() implementation supplied by TAP::Object
82 my $args = shift || {};
85 for my $key (qw( argv rc_opts includes modules state plugins rules )) {
88 $self->{harness_class} = 'TAP::Harness';
90 for my $attr (@ATTR) {
91 if ( exists $args->{$attr} ) {
93 # TODO: Some validation here
94 $self->{$attr} = $args->{$attr};
98 my %env_provides_default = (
99 HARNESS_TIMER => 'timer',
102 while ( my ( $env, $attr ) = each %env_provides_default ) {
103 $self->{$attr} = 1 if $ENV{$env};
105 $self->state_class('App::Prove::State');
109 =head3 C<state_class>
111 Getter/setter for the name of the class used for maintaining state. This
112 class should either subclass from C<App::Prove::State> or provide an identical
115 =head3 C<state_manager>
117 Getter/setter for the instance of the C<state_class>.
121 =head3 C<add_rc_file>
123 $prove->add_rc_file('myproj/.proverc');
125 Called before C<process_args> to prepend the contents of an rc file to
131 my ( $self, $rc_file ) = @_;
134 open RC, "<$rc_file" or croak "Can't read $rc_file ($!)";
135 while ( defined( my $line = <RC> ) ) {
136 push @{ $self->{rc_opts} },
137 grep { defined and not /^#/ }
138 $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S+) }xg;
143 =head3 C<process_args>
145 $prove->process_args(@args);
147 Processes the command-line arguments. Attributes will be set
148 appropriately. Any filenames may be found in the C<argv> attribute.
150 Dies on invalid arguments.
158 unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
160 # Preprocess meta-args.
162 while ( defined( my $arg = shift ) ) {
163 if ( $arg eq '--norc' ) {
166 elsif ( $arg eq '--rc' ) {
167 defined( my $rc = shift )
168 or croak "Missing argument to --rc";
171 elsif ( $arg =~ m{^--rc=(.+)$} ) {
179 # Everything after the arisdottle '::' gets passed as args to
181 if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
182 my @test_args = splice @args, $stop_at;
184 $self->{test_args} = \@test_args;
187 # Grab options from RC files
188 $self->add_rc_file($_) for grep -f, @rc;
189 unshift @args, @{ $self->{rc_opts} };
191 if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
192 die "Long options should be written with two dashes: ",
193 join( ', ', @bad ), "\n";
200 Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
202 # Don't add coderefs to GetOptions
204 'v|verbose' => \$self->{verbose},
205 'f|failures' => \$self->{failures},
206 'o|comments' => \$self->{comments},
207 'l|lib' => \$self->{lib},
208 'b|blib' => \$self->{blib},
209 's|shuffle' => \$self->{shuffle},
210 'color!' => \$self->{color},
211 'colour!' => \$self->{color},
212 'count!' => \$self->{show_count},
213 'c' => \$self->{color},
214 'D|dry' => \$self->{dry},
215 'ext=s' => \$self->{extension},
216 'harness=s' => \$self->{harness},
217 'ignore-exit' => \$self->{ignore_exit},
218 'formatter=s' => \$self->{formatter},
219 'r|recurse' => \$self->{recurse},
220 'reverse' => \$self->{backwards},
221 'p|parse' => \$self->{parse},
222 'q|quiet' => \$self->{quiet},
223 'Q|QUIET' => \$self->{really_quiet},
224 'e|exec=s' => \$self->{exec},
225 'm|merge' => \$self->{merge},
226 'I=s@' => $self->{includes},
227 'M=s@' => $self->{modules},
228 'P=s@' => $self->{plugins},
229 'state=s@' => $self->{state},
230 'directives' => \$self->{directives},
231 'h|help|?' => \$self->{show_help},
232 'H|man' => \$self->{show_man},
233 'V|version' => \$self->{show_version},
234 'a|archive=s' => \$self->{archive},
235 'j|jobs=i' => \$self->{jobs},
236 'timer' => \$self->{timer},
237 'T' => \$self->{taint_fail},
238 't' => \$self->{taint_warn},
239 'W' => \$self->{warnings_fail},
240 'w' => \$self->{warnings_warn},
241 'normalize' => \$self->{normalize},
242 'rules=s@' => $self->{rules},
243 ) or croak('Unable to continue');
245 # Stash the remainder of argv for later
246 $self->{argv} = [@ARGV];
255 return $_ if $_[$_] eq $want;
261 my ( $self, $verbosity ) = @_;
263 eval('use Pod::Usage 1.12 ()');
264 if ( my $err = $@ ) {
265 die 'Please install Pod::Usage for the --help option '
266 . '(or try `perldoc prove`.)'
270 Pod::Usage::pod2usage( { -verbose => $verbosity } );
278 return -t STDOUT && !$ENV{HARNESS_NOTTY} && !IS_WIN32;
286 if ( defined $self->color ? $self->color : $self->_color_default ) {
289 if ( !defined $self->show_count ) {
290 $args{show_count} = 1;
293 $args{show_count} = $self->show_count;
296 if ( $self->archive ) {
297 $self->require_harness( archive => 'TAP::Harness::Archive' );
298 $args{archive} = $self->archive;
301 if ( my $jobs = $self->jobs ) {
305 if ( my $harness_opt = $self->harness ) {
306 $self->require_harness( harness => $harness_opt );
309 if ( my $formatter = $self->formatter ) {
310 $args{formatter_class} = $formatter;
313 if ( $self->ignore_exit ) {
314 $args{ignore_exit} = 1;
317 if ( $self->taint_fail && $self->taint_warn ) {
318 die '-t and -T are mutually exclusive';
321 if ( $self->warnings_fail && $self->warnings_warn ) {
322 die '-w and -W are mutually exclusive';
325 for my $a (qw( lib switches )) {
326 my $method = "_get_$a";
327 my $val = $self->$method();
328 $args{$a} = $val if defined $val;
331 # Handle verbose, quiet, really_quiet flags
332 my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
334 my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
337 die "Only one of verbose, quiet or really_quiet should be specified\n"
340 $args{verbosity} = shift @verb_adj || 0;
342 for my $a (qw( merge failures comments timer directives normalize )) {
343 $args{$a} = 1 if $self->$a();
346 $args{errors} = 1 if $self->parse;
348 # defined but zero-length exec runs test files as binaries
349 $args{exec} = [ split( /\s+/, $self->exec ) ]
350 if ( defined( $self->exec ) );
352 if ( defined( my $test_args = $self->test_args ) ) {
353 $args{test_args} = $test_args;
356 if ( @{ $self->rules } ) {
358 for ( @{ $self->rules } ) {
362 elsif (/^seq=(.*)/) {
363 push @rules, { seq => $1 };
366 $args{rules} = { par => [@rules] };
369 return ( \%args, $self->{harness_class} );
373 my ( $self, $class, @search ) = @_;
375 croak "Bad module name $class"
376 unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
378 for my $pfx (@search) {
379 my $name = join( '::', $pfx, $class );
380 eval "require $name";
381 return $name unless $@;
384 eval "require $class";
385 return $class unless $@;
389 sub _load_extension {
390 my ( $self, $name, @search ) = @_;
393 if ( $name =~ /^(.*?)=(.*)/ ) {
395 @args = split( /,/, $2 );
398 if ( my $class = $self->_find_module( $name, @search ) ) {
399 $class->import(@args);
400 if ( $class->can('load') ) {
401 $class->load( { app_prove => $self, args => [@args] } );
405 croak "Can't load module $name";
409 sub _load_extensions {
410 my ( $self, $ext, @search ) = @_;
411 $self->_load_extension( $_, @search ) for @$ext;
416 Perform whatever actions the command line args specified. The C<prove>
417 command line tool consists of the following code:
421 my $app = App::Prove->new;
422 $app->process_args(@ARGV);
423 exit( $app->run ? 0 : 1 ); # if you need the exit code
430 unless ( $self->state_manager ) {
431 $self->state_manager(
432 $self->state_class->new( { store => STATE_FILE } ) );
435 if ( $self->show_help ) {
438 elsif ( $self->show_man ) {
441 elsif ( $self->show_version ) {
442 $self->print_version;
444 elsif ( $self->dry ) {
445 print "$_\n" for $self->_get_tests;
449 $self->_load_extensions( $self->modules );
450 $self->_load_extensions( $self->plugins, PLUGINS );
452 local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
454 return $self->_runtests( $self->_get_args, $self->_get_tests );
463 my $state = $self->state_manager;
464 my $ext = $self->extension;
465 $state->extension($ext) if defined $ext;
466 if ( defined( my $state_switch = $self->state ) ) {
467 $state->apply_switch(@$state_switch);
470 my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
472 $self->_shuffle(@tests) if $self->shuffle;
473 @tests = reverse @tests if $self->backwards;
479 my ( $self, $args, $harness_class, @tests ) = @_;
480 my $harness = $harness_class->new($args);
482 my $state = $self->state_manager;
486 $state->observe_test(@_);
491 after_runtests => sub {
496 my $aggregator = $harness->runtests(@tests);
498 return !$aggregator->has_errors;
505 # notes that -T or -t must be at the front of the switches!
506 if ( $self->taint_fail ) {
507 push @switches, '-T';
509 elsif ( $self->taint_warn ) {
510 push @switches, '-t';
512 if ( $self->warnings_fail ) {
513 push @switches, '-W';
515 elsif ( $self->warnings_warn ) {
516 push @switches, '-w';
519 push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} );
521 return @switches ? \@switches : ();
531 push @libs, 'blib/lib', 'blib/arch';
533 if ( @{ $self->includes } ) {
534 push @libs, @{ $self->includes };
538 @libs = map { File::Spec->rel2abs($_) } @libs;
541 return @libs ? \@libs : ();
547 # Fisher-Yates shuffle
551 @_[ $i, $j ] = @_[ $j, $i ];
556 =head3 C<require_harness>
558 Load a harness replacement class.
560 $prove->require_harness($for => $class_name);
564 sub require_harness {
565 my ( $self, $for, $class ) = @_;
567 my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
569 # Emulate Perl's -MModule=arg1,arg2 behaviour
570 $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
573 die "$class_name is required to use the --$for feature: $@" if $@;
575 $self->{harness_class} = $class_name;
580 =head3 C<print_version>
582 Display the version numbers of the loaded L<TAP::Harness> and the
590 "TAP::Harness v%s and Perl v%vd\n",
591 $TAP::Harness::VERSION, $^V
599 # vim:ts=4:sw=4:et:sta
605 After command line parsing the following attributes reflect the values
606 of the corresponding command line switches. They may be altered before
655 =item C<really_quiet>
667 =item C<show_version>
685 =item C<warnings_fail>
687 =item C<warnings_warn>
693 C<App::Prove> provides support for 3rd-party plugins. These are currently
694 loaded at run-time, I<after> arguments have been parsed (so you can not
695 change the way arguments are processed, sorry), typically with the
696 C<< -PI<plugin> >> switch, eg:
700 This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
701 that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
703 You can pass an argument to your plugin by appending an C<=> after the plugin
704 name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas:
706 prove -PMyPlugin=foo,bar,baz
708 These are passed in to your plugin's C<load()> class method (if it has one),
709 along with a reference to the C<App::Prove> object that is invoking your plugin:
712 my ($class, $p) = @_;
714 my @args = @{ $p->{args} };
715 # @args will contain ( 'foo', 'bar', 'baz' )
716 $p->{app_prove}->do_something;
720 Note that the user's arguments are also passed to your plugin's C<import()>
721 function as a list, eg:
724 my ($class, @args) = @_;
725 # @args will contain ( 'foo', 'bar', 'baz' )
729 This is for backwards compatibility, and may be deprecated in the future.
733 Here's a sample plugin, for your reference:
735 package App::Prove::Plugin::Foo;
737 # Sample plugin, try running with:
738 # prove -PFoo=bar -r -j3
740 # prove -PFoo=bar,My::Formatter
746 my ($class, $p) = @_;
747 my @args = @{ $p->{args} };
748 my $app = $p->{app_prove};
750 print "loading plugin: $class, args: ", join(', ', @args ), "\n";
756 $app->formatter( $args[1] ) if @args > 1;
758 # print some of App::Prove's state:
759 for my $attr (qw( jobs quiet really_quiet recurse verbose )) {
760 my $val = $app->$attr;
761 $val = 'undef' unless defined( $val );
762 print "$attr: $val\n";
772 L<prove>, L<TAP::Harness>