4 use vars qw($VERSION @ISA);
8 use TAP::Parser::Utils qw( split_shell );
11 use App::Prove::State;
14 @ISA = qw(TAP::Object);
18 App::Prove - Implements the C<prove> command.
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.
38 my $app = App::Prove->new;
39 $app->process_args(@ARGV);
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 );
48 use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
49 use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
51 use constant PLUGINS => 'App::Prove::Plugin';
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
63 for my $attr (@ATTR) {
67 croak "$attr is read-only" if @_;
79 Create a new C<App::Prove>. Optionally a hash ref of attribute
80 initializers may be passed.
84 # new() implementation supplied by TAP::Object
88 my $args = shift || {};
91 for my $key (qw( argv rc_opts includes modules state plugins )) {
94 $self->{harness_class} = 'TAP::Harness';
95 $self->{_state} = App::Prove::State->new( { store => STATE_FILE } );
97 for my $attr (@ATTR) {
98 if ( exists $args->{$attr} ) {
100 # TODO: Some validation here
101 $self->{$attr} = $args->{$attr};
108 =head3 C<add_rc_file>
110 $prove->add_rc_file('myproj/.proverc');
112 Called before C<process_args> to prepend the contents of an rc file to
118 my ( $self, $rc_file ) = @_;
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;
129 =head3 C<process_args>
131 $prove->process_args(@args);
133 Processes the command-line arguments. Attributes will be set
134 appropriately. Any filenames may be found in the C<argv> attribute.
136 Dies on invalid arguments.
144 unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
146 # Preprocess meta-args.
148 while ( defined( my $arg = shift ) ) {
149 if ( $arg eq '--norc' ) {
152 elsif ( $arg eq '--rc' ) {
153 defined( my $rc = shift )
154 or croak "Missing argument to --rc";
157 elsif ( $arg =~ m{^--rc=(.+)$} ) {
165 # Everything after the arisdottle '::' gets passed as args to
167 if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
168 my @test_args = splice @args, $stop_at;
170 $self->{test_args} = \@test_args;
173 # Grab options from RC files
174 $self->add_rc_file($_) for grep -f, @rc;
175 unshift @args, @{ $self->{rc_opts} };
177 if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
178 die "Long options should be written with two dashes: ",
179 join( ', ', @bad ), "\n";
186 Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
188 # Don't add coderefs to 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');
228 # Stash the remainder of argv for later
229 $self->{argv} = [@ARGV];
238 return $_ if $_[$_] eq $want;
244 my ( $self, $verbosity ) = @_;
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`.)'
253 Pod::Usage::pod2usage( { -verbose => $verbosity } );
261 return -t STDOUT && !IS_WIN32;
269 if ( defined $self->color ? $self->color : $self->_color_default ) {
273 if ( $self->archive ) {
274 $self->require_harness( archive => 'TAP::Harness::Archive' );
275 $args{archive} = $self->archive;
278 if ( my $jobs = $self->jobs ) {
282 if ( my $fork = $self->fork ) {
286 if ( my $harness_opt = $self->harness ) {
287 $self->require_harness( harness => $harness_opt );
290 if ( my $formatter = $self->formatter ) {
291 $args{formatter_class} = $formatter;
294 if ( $self->ignore_exit ) {
295 $args{ignore_exit} = 1;
298 if ( $self->taint_fail && $self->taint_warn ) {
299 die '-t and -T are mutually exclusive';
302 if ( $self->warnings_fail && $self->warnings_warn ) {
303 die '-w and -W are mutually exclusive';
306 for my $a (qw( lib switches )) {
307 my $method = "_get_$a";
308 my $val = $self->$method();
309 $args{$a} = $val if defined $val;
312 # Handle verbose, quiet, really_quiet flags
313 my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
315 my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
318 die "Only one of verbose, quiet or really_quiet should be specified\n"
321 $args{verbosity} = shift @verb_adj || 0;
323 for my $a (qw( merge failures timer directives )) {
324 $args{$a} = 1 if $self->$a();
327 $args{errors} = 1 if $self->parse;
329 # defined but zero-length exec runs test files as binaries
330 $args{exec} = [ split( /\s+/, $self->exec ) ]
331 if ( defined( $self->exec ) );
333 if ( defined( my $test_args = $self->test_args ) ) {
334 $args{test_args} = $test_args;
337 return ( \%args, $self->{harness_class} );
341 my ( $self, $class, @search ) = @_;
343 croak "Bad module name $class"
344 unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
346 for my $pfx (@search) {
347 my $name = join( '::', $pfx, $class );
349 eval "require $name";
350 return $name unless $@;
353 eval "require $class";
354 return $class unless $@;
358 sub _load_extension {
359 my ( $self, $class, @search ) = @_;
362 if ( $class =~ /^(.*?)=(.*)/ ) {
364 @args = split( /,/, $2 );
367 if ( my $name = $self->_find_module( $class, @search ) ) {
368 $name->import(@args);
371 croak "Can't load module $class";
375 sub _load_extensions {
376 my ( $self, $ext, @search ) = @_;
377 $self->_load_extension( $_, @search ) for @$ext;
382 Perform whatever actions the command line args specified. The C<prove>
383 command line tool consists of the following code:
387 my $app = App::Prove->new;
388 $app->process_args(@ARGV);
396 if ( $self->show_help ) {
399 elsif ( $self->show_man ) {
402 elsif ( $self->show_version ) {
403 $self->print_version;
405 elsif ( $self->dry ) {
406 print "$_\n" for $self->_get_tests;
410 $self->_load_extensions( $self->modules );
411 $self->_load_extensions( $self->plugins, PLUGINS );
413 local $ENV{TEST_VERBOSE} = 1 if $self->verbose;
415 return $self->_runtests( $self->_get_args, $self->_get_tests );
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);
431 my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
433 $self->_shuffle(@tests) if $self->shuffle;
434 @tests = reverse @tests if $self->backwards;
440 my ( $self, $args, $harness_class, @tests ) = @_;
441 my $harness = $harness_class->new($args);
445 $self->{_state}->observe_test(@_);
449 my $aggregator = $harness->runtests(@tests);
451 return $aggregator->has_problems ? 0 : 1;
458 # notes that -T or -t must be at the front of the switches!
459 if ( $self->taint_fail ) {
460 push @switches, '-T';
462 elsif ( $self->taint_warn ) {
463 push @switches, '-t';
465 if ( $self->warnings_fail ) {
466 push @switches, '-W';
468 elsif ( $self->warnings_warn ) {
469 push @switches, '-w';
472 push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} );
474 return @switches ? \@switches : ();
484 push @libs, 'blib/lib', 'blib/arch';
486 if ( @{ $self->includes } ) {
487 push @libs, @{ $self->includes };
491 @libs = map { File::Spec->rel2abs($_) } @libs;
494 return @libs ? \@libs : ();
500 # Fisher-Yates shuffle
504 @_[ $i, $j ] = @_[ $j, $i ];
509 =head3 C<require_harness>
511 Load a harness replacement class.
513 $prove->require_harness($for => $class_name);
517 sub require_harness {
518 my ( $self, $for, $class ) = @_;
520 my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/;
522 # Emulate Perl's -MModule=arg1,arg2 behaviour
523 $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!;
526 die "$class_name is required to use the --$for feature: $@" if $@;
528 $self->{harness_class} = $class_name;
533 =head3 C<print_version>
535 Display the version numbers of the loaded L<TAP::Harness> and the
543 "TAP::Harness v%s and Perl v%vd\n",
544 $TAP::Harness::VERSION, $^V
552 # vim:ts=4:sw=4:et:sta
558 After command line parsing the following attributes reflect the values
559 of the corresponding command line switches. They may be altered before
608 =item C<really_quiet>
616 =item C<show_version>
632 =item C<warnings_fail>
634 =item C<warnings_warn>