10 use vars qw($VERSION);
14 App::Prove - Implements the C<prove> command.
26 L<Test::Harness> provides a command, C<prove>, which runs a TAP based
27 test suite and prints a report. The C<prove> command is a minimal
28 wrapper around an instance of this module.
34 my $app = App::Prove->new;
35 $app->process_args(@ARGV);
40 use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
41 use constant IS_VMS => $^O eq 'VMS';
42 use constant IS_UNIXY => !( IS_VMS || IS_WIN32 );
44 use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove';
45 use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc';
47 use constant PLUGINS => 'App::Prove::Plugin';
53 archive argv blib color directives exec failures fork formatter
54 harness includes modules plugins jobs lib merge parse quiet
55 really_quiet recurse backwards shuffle taint_fail taint_warn timer
56 verbose warnings_fail warnings_warn show_help show_man
57 show_version test_args state
59 for my $attr (@ATTR) {
63 croak "$attr is read-only" if @_;
75 Create a new C<App::Prove>. Optionally a hash ref of attribute
76 initializers may be passed.
82 my $args = shift || {};
91 harness_class => 'TAP::Harness',
92 _state => App::Prove::State->new( { store => STATE_FILE } ),
95 for my $attr (@ATTR) {
96 if ( exists $args->{$attr} ) {
98 # TODO: Some validation here
99 $self->{$attr} = $args->{$attr};
105 =head3 C<add_rc_file>
107 $prove->add_rc_file('myproj/.proverc');
109 Called before C<process_args> to prepend the contents of an rc file to
115 my ( $self, $rc_file ) = @_;
118 open RC, "<$rc_file" or croak "Can't read $rc_file ($!)";
119 while ( defined( my $line = <RC> ) ) {
120 push @{ $self->{rc_opts} }, grep $_ && $_ !~ /^#/,
121 $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S*) }xg;
126 =head3 C<process_args>
128 $prove->process_args(@args);
130 Processes the command-line arguments. Attributes will be set
131 appropriately. Any filenames may be found in the C<argv> attribute.
133 Dies on invalid arguments.
141 unshift @rc, glob '~/' . RC_FILE if IS_UNIXY;
143 # Preprocess meta-args.
145 while ( defined( my $arg = shift ) ) {
146 if ( $arg eq '--norc' ) {
149 elsif ( $arg eq '--rc' ) {
150 defined( my $rc = shift )
151 or croak "Missing argument to --rc";
154 elsif ( $arg =~ m{^--rc=(.+)$} ) {
162 # Everything after the arisdottle '::' gets passed as args to
164 if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) {
165 my @test_args = splice @args, $stop_at;
167 $self->{test_args} = \@test_args;
170 # Grab options from RC files
171 $self->add_rc_file($_) for grep -f, @rc;
172 unshift @args, @{ $self->{rc_opts} };
174 if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) {
175 die "Long options should be written with two dashes: ",
176 join( ', ', @bad ), "\n";
183 Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
185 # Don't add coderefs to GetOptions
187 'v|verbose' => \$self->{verbose},
188 'f|failures' => \$self->{failures},
189 'l|lib' => \$self->{lib},
190 'b|blib' => \$self->{blib},
191 's|shuffle' => \$self->{shuffle},
192 'color!' => \$self->{color},
193 'c' => \$self->{color},
194 'harness=s' => \$self->{harness},
195 'formatter=s' => \$self->{formatter},
196 'r|recurse' => \$self->{recurse},
197 'reverse' => \$self->{backwards},
198 'fork' => \$self->{fork},
199 'p|parse' => \$self->{parse},
200 'q|quiet' => \$self->{quiet},
201 'Q|QUIET' => \$self->{really_quiet},
202 'e|exec=s' => \$self->{exec},
203 'm|merge' => \$self->{merge},
204 'I=s@' => $self->{includes},
205 'M=s@' => $self->{modules},
206 'P=s@' => $self->{plugins},
207 'state=s@' => $self->{state},
208 'directives' => \$self->{directives},
209 'h|help|?' => \$self->{show_help},
210 'H|man' => \$self->{show_man},
211 'V|version' => \$self->{show_version},
212 'a|archive=s' => \$self->{archive},
213 'j|jobs=i' => \$self->{jobs},
214 'timer' => \$self->{timer},
215 'T' => \$self->{taint_fail},
216 't' => \$self->{taint_warn},
217 'W' => \$self->{warnings_fail},
218 'w' => \$self->{warnings_warn},
219 ) or croak('Unable to continue');
221 # Stash the remainder of argv for later
222 $self->{argv} = [@ARGV];
231 return $_ if $_[$_] eq $want;
236 sub _exit { exit( $_[1] || 0 ) }
239 my ( $self, $verbosity ) = @_;
241 eval('use Pod::Usage 1.12 ()');
242 if ( my $err = $@ ) {
243 die 'Please install Pod::Usage for the --help option '
244 . '(or try `perldoc prove`.)'
248 Pod::Usage::pod2usage( { -verbose => $verbosity } );
256 return -t STDOUT && !IS_WIN32;
264 if ( defined $self->color ? $self->color : $self->_color_default ) {
268 if ( $self->archive ) {
269 $self->require_harness( archive => 'TAP::Harness::Archive' );
270 $args{archive} = $self->archive;
273 if ( my $jobs = $self->jobs ) {
277 if ( my $fork = $self->fork ) {
281 if ( my $harness_opt = $self->harness ) {
282 $self->require_harness( harness => $harness_opt );
285 if ( my $formatter = $self->formatter ) {
286 $args{formatter_class} = $formatter;
289 if ( $self->taint_fail && $self->taint_warn ) {
290 die '-t and -T are mutually exclusive';
293 if ( $self->warnings_fail && $self->warnings_warn ) {
294 die '-w and -W are mutually exclusive';
297 for my $a (qw( lib switches )) {
298 my $method = "_get_$a";
299 my $val = $self->$method();
300 $args{$a} = $val if defined $val;
303 # Handle verbose, quiet, really_quiet flags
304 my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, );
306 my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 }
309 die "Only one of verbose, quiet or really_quiet should be specified\n"
312 $args{verbosity} = shift @verb_adj || 0;
314 for my $a (qw( merge failures timer directives )) {
315 $args{$a} = 1 if $self->$a();
318 $args{errors} = 1 if $self->parse;
320 # defined but zero-length exec runs test files as binaries
321 $args{exec} = [ split( /\s+/, $self->exec ) ]
322 if ( defined( $self->exec ) );
324 if ( defined( my $test_args = $self->test_args ) ) {
325 $args{test_args} = $test_args;
328 return ( \%args, $self->{harness_class} );
332 my ( $self, $class, @search ) = @_;
334 croak "Bad module name $class"
335 unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
337 for my $pfx (@search) {
338 my $name = join( '::', $pfx, $class );
340 eval "require $name";
341 return $name unless $@;
344 eval "require $class";
345 return $class unless $@;
349 sub _load_extension {
350 my ( $self, $class, @search ) = @_;
353 if ( $class =~ /^(.*?)=(.*)/ ) {
355 @args = split( /,/, $2 );
358 if ( my $name = $self->_find_module( $class, @search ) ) {
359 $name->import(@args);
362 croak "Can't load module $class";
366 sub _load_extensions {
367 my ( $self, $ext, @search ) = @_;
368 $self->_load_extension( $_, @search ) for @$ext;
373 Perform whatever actions the command line args specified. The C<prove>
374 command line tool consists of the following code:
378 my $app = App::Prove->new;
379 $app->process_args(@ARGV);
387 if ( $self->show_help ) {
390 elsif ( $self->show_man ) {
393 elsif ( $self->show_version ) {
394 $self->print_version;
398 $self->_load_extensions( $self->modules );
399 $self->_load_extensions( $self->plugins, PLUGINS );
401 my $state = $self->{_state};
402 if ( defined( my $state_switch = $self->state ) ) {
403 $state->apply_switch(@$state_switch);
406 my @tests = $state->get_tests( $self->recurse, @{ $self->argv } );
408 $self->_shuffle(@tests) if $self->shuffle;
409 @tests = reverse @tests if $self->backwards;
411 $self->_runtests( $self->_get_args, @tests );
418 my ( $self, $args, $harness_class, @tests ) = @_;
419 my $harness = $harness_class->new($args);
423 $self->{_state}->observe_test(@_);
427 my $aggregator = $harness->runtests(@tests);
429 $self->_exit( $aggregator->has_problems ? 1 : 0 );
438 # notes that -T or -t must be at the front of the switches!
439 if ( $self->taint_fail ) {
440 push @switches, '-T';
442 elsif ( $self->taint_warn ) {
443 push @switches, '-t';
445 if ( $self->warnings_fail ) {
446 push @switches, '-W';
448 elsif ( $self->warnings_warn ) {
449 push @switches, '-w';
452 return @switches ? \@switches : ();
462 push @libs, 'blib/lib', 'blib/arch';
464 if ( @{ $self->includes } ) {
465 push @libs, @{ $self->includes };
469 @libs = map { File::Spec->rel2abs($_) } @libs;
472 return @libs ? \@libs : ();
478 # Fisher-Yates shuffle
482 @_[ $i, $j ] = @_[ $j, $i ];
487 =head3 C<require_harness>
489 Load a harness replacement class.
491 $prove->require_harness($for => $class_name);
495 sub require_harness {
496 my ( $self, $for, $class ) = @_;
498 eval("require $class");
499 die "$class is required to use the --$for feature: $@" if $@;
501 $self->{harness_class} = $class;
506 =head3 C<print_version>
508 Display the version numbers of the loaded L<TAP::Harness> and the
516 "TAP::Harness v%s and Perl v%vd\n",
517 $TAP::Harness::VERSION, $^V
525 # vim:ts=4:sw=4:et:sta
531 After command line parsing the following attributes reflect the values
532 of the corresponding command line switches. They may be altered before
575 =item C<really_quiet>
583 =item C<show_version>
599 =item C<warnings_fail>
601 =item C<warnings_warn>