5 use TAP::Parser::Utils qw( split_shell );
11 use vars qw($VERSION);
15 App::Prove - Implements the C<prove> command.
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.
35 my $app = App::Prove->new;
36 $app->process_args(@ARGV);
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 );
45 use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
46 use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
48 use constant PLUGINS => 'App::Prove::Plugin';
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
60 for my $attr (@ATTR) {
64 croak "$attr is read-only" if @_;
76 Create a new C<App::Prove>. Optionally a hash ref of attribute
77 initializers may be passed.
83 my $args = shift || {};
92 harness_class => 'TAP::Harness',
93 _state => App::Prove::State->new( { store => STATE_FILE } ),
96 for my $attr (@ATTR) {
97 if ( exists $args->{$attr} ) {
99 # TODO: Some validation here
100 $self->{$attr} = $args->{$attr};
106 =head3 C<add_rc_file>
108 $prove->add_rc_file('myproj/.proverc');
110 Called before C<process_args> to prepend the contents of an rc file to
116 my ( $self, $rc_file ) = @_;
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;
127 =head3 C<process_args>
129 $prove->process_args(@args);
131 Processes the command-line arguments. Attributes will be set
132 appropriately. Any filenames may be found in the C<argv> attribute.
134 Dies on invalid arguments.
142 unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
144 # Preprocess meta-args.
146 while ( defined( my $arg = shift ) ) {
147 if ( $arg eq '--norc' ) {
150 elsif ( $arg eq '--rc' ) {
151 defined( my $rc = shift )
152 or croak "Missing argument to --rc";
155 elsif ( $arg =~ m{^--rc=(.+)$} ) {
163 # Everything after the arisdottle '::' gets passed as args to
165 if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
166 my @test_args = splice @args, $stop_at;
168 $self->{test_args} = \@test_args;
171 # Grab options from RC files
172 $self->add_rc_file($_) for grep -f, @rc;
173 unshift @args, @{ $self->{rc_opts} };
175 if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
176 die "Long options should be written with two dashes: ",
177 join( ', ', @bad ), "\n";
184 Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
186 # Don't add coderefs to 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');
224 # Stash the remainder of argv for later
225 $self->{argv} = [@ARGV];
234 return $_ if $_[$_] eq $want;
239 sub _exit { exit( $_[1] || 0 ) }
242 my ( $self, $verbosity ) = @_;
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`.)'
251 Pod::Usage::pod2usage( { -verbose => $verbosity } );
259 return -t STDOUT && !IS_WIN32;
267 if ( defined $self->color ? $self->color : $self->_color_default ) {
271 if ( $self->archive ) {
272 $self->require_harness( archive => 'TAP::Harness::Archive' );
273 $args{archive} = $self->archive;
276 if ( my $jobs = $self->jobs ) {
280 if ( my $fork = $self->fork ) {
284 if ( my $harness_opt = $self->harness ) {
285 $self->require_harness( harness => $harness_opt );
288 if ( my $formatter = $self->formatter ) {
289 $args{formatter_class} = $formatter;
292 if ( $self->taint_fail && $self->taint_warn ) {
293 die '-t and -T are mutually exclusive';
296 if ( $self->warnings_fail && $self->warnings_warn ) {
297 die '-w and -W are mutually exclusive';
300 for my $a (qw( lib switches )) {
301 my $method = "_get_$a";
302 my $val = $self->$method();
303 $args{$a} = $val if defined $val;
306 # Handle verbose, quiet, really_quiet flags
307 my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
309 my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
312 die "Only one of verbose, quiet or really_quiet should be specified\n"
315 $args{verbosity} = shift @verb_adj || 0;
317 for my $a (qw( merge failures timer directives )) {
318 $args{$a} = 1 if $self->$a();
321 $args{errors} = 1 if $self->parse;
323 # defined but zero-length exec runs test files as binaries
324 $args{exec} = [ split( /\s+/, $self->exec ) ]
325 if ( defined( $self->exec ) );
327 if ( defined( my $test_args = $self->test_args ) ) {
328 $args{test_args} = $test_args;
331 return ( \%args, $self->{harness_class} );
335 my ( $self, $class, @search ) = @_;
337 croak "Bad module name $class"
338 unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
340 for my $pfx (@search) {
341 my $name = join( '::', $pfx, $class );
343 eval "require $name";
344 return $name unless $@;
347 eval "require $class";
348 return $class unless $@;
352 sub _load_extension {
353 my ( $self, $class, @search ) = @_;
356 if ( $class =~ /^(.*?)=(.*)/ ) {
358 @args = split( /,/, $2 );
361 if ( my $name = $self->_find_module( $class, @search ) ) {
362 $name->import(@args);
365 croak "Can't load module $class";
369 sub _load_extensions {
370 my ( $self, $ext, @search ) = @_;
371 $self->_load_extension( $_, @search ) for @$ext;
376 Perform whatever actions the command line args specified. The C<prove>
377 command line tool consists of the following code:
381 my $app = App::Prove->new;
382 $app->process_args(@ARGV);
390 if ( $self->show_help ) {
393 elsif ( $self->show_man ) {
396 elsif ( $self->show_version ) {
397 $self->print_version;
399 elsif ( $self->dry ) {
400 print "$_\n" for $self->_get_tests;
404 $self->_load_extensions( $self->modules );
405 $self->_load_extensions( $self->plugins, PLUGINS );
407 local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
409 $self->_runtests( $self->_get_args, $self->_get_tests );
418 my $state = $self->{_state};
419 if ( defined( my $state_switch = $self->state ) ) {
420 $state->apply_switch(@$state_switch);
423 my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
425 $self->_shuffle(@tests) if $self->shuffle;
426 @tests = reverse @tests if $self->backwards;
432 my ( $self, $args, $harness_class, @tests ) = @_;
433 my $harness = $harness_class->new($args);
437 $self->{_state}->observe_test(@_);
441 my $aggregator = $harness->runtests(@tests);
443 $self->_exit( $aggregator->has_problems ? 1 : 0 );
452 # notes that -T or -t must be at the front of the switches!
453 if ( $self->taint_fail ) {
454 push @switches, '-T';
456 elsif ( $self->taint_warn ) {
457 push @switches, '-t';
459 if ( $self->warnings_fail ) {
460 push @switches, '-W';
462 elsif ( $self->warnings_warn ) {
463 push @switches, '-w';
466 push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} );
468 return @switches ? \@switches : ();
478 push @libs, 'blib/lib', 'blib/arch';
480 if ( @{ $self->includes } ) {
481 push @libs, @{ $self->includes };
485 @libs = map { File::Spec->rel2abs($_) } @libs;
488 return @libs ? \@libs : ();
494 # Fisher-Yates shuffle
498 @_[ $i, $j ] = @_[ $j, $i ];
503 =head3 C<require_harness>
505 Load a harness replacement class.
507 $prove->require_harness($for => $class_name);
511 sub require_harness {
512 my ( $self, $for, $class ) = @_;
514 eval("require $class");
515 die "$class is required to use the --$for feature: $@" if $@;
517 $self->{harness_class} = $class;
522 =head3 C<print_version>
524 Display the version numbers of the loaded L<TAP::Harness> and the
532 "TAP::Harness v%s and Perl v%vd\n",
533 $TAP::Harness::VERSION, $^V
541 # vim:ts=4:sw=4:et:sta
547 After command line parsing the following attributes reflect the values
548 of the corresponding command line switches. They may be altered before
593 =item C<really_quiet>
601 =item C<show_version>
617 =item C<warnings_fail>
619 =item C<warnings_warn>