Commit | Line | Data |
7f01fda6 |
1 | package App::Prove; |
2 | |
3 | use strict; |
f7c69158 |
4 | use vars qw($VERSION @ISA); |
5 | |
6 | use TAP::Object (); |
7f01fda6 |
7 | use TAP::Harness; |
bd3ac2f1 |
8 | use TAP::Parser::Utils qw( split_shell ); |
7f01fda6 |
9 | use File::Spec; |
10 | use Getopt::Long; |
11 | use App::Prove::State; |
12 | use Carp; |
13 | |
f7c69158 |
14 | @ISA = qw(TAP::Object); |
7f01fda6 |
15 | |
16 | =head1 NAME |
17 | |
18 | App::Prove - Implements the C<prove> command. |
19 | |
20 | =head1 VERSION |
21 | |
27fc0087 |
22 | Version 3.14 |
7f01fda6 |
23 | |
24 | =cut |
25 | |
27fc0087 |
26 | $VERSION = '3.14'; |
7f01fda6 |
27 | |
28 | =head1 DESCRIPTION |
29 | |
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. |
33 | |
34 | =head1 SYNOPSIS |
35 | |
36 | use App::Prove; |
37 | |
38 | my $app = App::Prove->new; |
39 | $app->process_args(@ARGV); |
40 | $app->run; |
41 | |
42 | =cut |
43 | |
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 ); |
47 | |
48 | use constant STATE_FILE => IS_UNIXY ? '.prove' : '_prove'; |
49 | use constant RC_FILE => IS_UNIXY ? '.proverc' : '_proverc'; |
50 | |
51 | use constant PLUGINS => 'App::Prove::Plugin'; |
52 | |
53 | my @ATTR; |
54 | |
55 | BEGIN { |
56 | @ATTR = qw( |
27fc0087 |
57 | archive argv blib show_count color directives exec failures fork |
58 | formatter harness includes modules plugins jobs lib merge parse quiet |
7f01fda6 |
59 | really_quiet recurse backwards shuffle taint_fail taint_warn timer |
27fc0087 |
60 | verbose warnings_fail warnings_warn show_help show_man show_version |
61 | test_args state dry extension ignore_exit rules state_manager |
7f01fda6 |
62 | ); |
63 | for my $attr (@ATTR) { |
64 | no strict 'refs'; |
65 | *$attr = sub { |
66 | my $self = shift; |
27fc0087 |
67 | $self->{$attr} = shift if @_; |
68 | return $self->{$attr}; |
7f01fda6 |
69 | }; |
70 | } |
71 | } |
72 | |
73 | =head1 METHODS |
74 | |
75 | =head2 Class Methods |
76 | |
77 | =head3 C<new> |
78 | |
79 | Create a new C<App::Prove>. Optionally a hash ref of attribute |
80 | initializers may be passed. |
81 | |
82 | =cut |
83 | |
f7c69158 |
84 | # new() implementation supplied by TAP::Object |
85 | |
86 | sub _initialize { |
87 | my $self = shift; |
7f01fda6 |
88 | my $args = shift || {}; |
89 | |
f7c69158 |
90 | # setup defaults: |
91 | for my $key (qw( argv rc_opts includes modules state plugins rules )) { |
92 | $self->{$key} = []; |
93 | } |
94 | $self->{harness_class} = 'TAP::Harness'; |
7f01fda6 |
95 | |
96 | for my $attr (@ATTR) { |
97 | if ( exists $args->{$attr} ) { |
98 | |
99 | # TODO: Some validation here |
100 | $self->{$attr} = $args->{$attr}; |
101 | } |
102 | } |
f7c69158 |
103 | |
104 | my %env_provides_default = ( |
105 | HARNESS_TIMER => 'timer', |
106 | ); |
107 | |
108 | while ( my ( $env, $attr ) = each %env_provides_default ) { |
109 | $self->{$attr} = 1 if $ENV{$env}; |
110 | } |
27fc0087 |
111 | $self->state_manager( |
112 | $self->state_class->new( { store => STATE_FILE } ) ); |
f7c69158 |
113 | |
7f01fda6 |
114 | return $self; |
115 | } |
116 | |
27fc0087 |
117 | =head3 C<state_class> |
118 | |
119 | Returns the name of the class used for maintaining state. This class should |
120 | either subclass from C<App::Prove::State> or provide an identical interface. |
121 | |
122 | =head3 C<state_manager> |
123 | |
124 | Getter/setter for the an instane of the C<state_class>. |
125 | |
126 | =cut |
127 | |
128 | sub state_class { |
129 | return 'App::Prove::State'; |
130 | } |
131 | |
7f01fda6 |
132 | =head3 C<add_rc_file> |
133 | |
134 | $prove->add_rc_file('myproj/.proverc'); |
135 | |
136 | Called before C<process_args> to prepend the contents of an rc file to |
137 | the options. |
138 | |
139 | =cut |
140 | |
141 | sub add_rc_file { |
142 | my ( $self, $rc_file ) = @_; |
143 | |
144 | local *RC; |
145 | open RC, "<$rc_file" or croak "Can't read $rc_file ($!)"; |
146 | while ( defined( my $line = <RC> ) ) { |
147 | push @{ $self->{rc_opts} }, grep $_ && $_ !~ /^#/, |
148 | $line =~ m{ ' ([^']*) ' | " ([^"]*) " | (\#.*) | (\S*) }xg; |
149 | } |
150 | close RC; |
151 | } |
152 | |
153 | =head3 C<process_args> |
154 | |
155 | $prove->process_args(@args); |
156 | |
157 | Processes the command-line arguments. Attributes will be set |
158 | appropriately. Any filenames may be found in the C<argv> attribute. |
159 | |
160 | Dies on invalid arguments. |
161 | |
162 | =cut |
163 | |
164 | sub process_args { |
165 | my $self = shift; |
166 | |
167 | my @rc = RC_FILE; |
168 | unshift @rc, glob '~/' . RC_FILE if IS_UNIXY; |
169 | |
170 | # Preprocess meta-args. |
171 | my @args; |
172 | while ( defined( my $arg = shift ) ) { |
173 | if ( $arg eq '--norc' ) { |
174 | @rc = (); |
175 | } |
176 | elsif ( $arg eq '--rc' ) { |
177 | defined( my $rc = shift ) |
178 | or croak "Missing argument to --rc"; |
179 | push @rc, $rc; |
180 | } |
181 | elsif ( $arg =~ m{^--rc=(.+)$} ) { |
182 | push @rc, $1; |
183 | } |
184 | else { |
185 | push @args, $arg; |
186 | } |
187 | } |
188 | |
189 | # Everything after the arisdottle '::' gets passed as args to |
190 | # test programs. |
191 | if ( defined( my $stop_at = _first_pos( '::', @args ) ) ) { |
192 | my @test_args = splice @args, $stop_at; |
193 | shift @test_args; |
194 | $self->{test_args} = \@test_args; |
195 | } |
196 | |
197 | # Grab options from RC files |
198 | $self->add_rc_file($_) for grep -f, @rc; |
199 | unshift @args, @{ $self->{rc_opts} }; |
200 | |
201 | if ( my @bad = map {"-$_"} grep {/^-(man|help)$/} @args ) { |
202 | die "Long options should be written with two dashes: ", |
203 | join( ', ', @bad ), "\n"; |
204 | } |
205 | |
206 | # And finally... |
207 | |
208 | { |
209 | local @ARGV = @args; |
210 | Getopt::Long::Configure( 'no_ignore_case', 'bundling' ); |
211 | |
212 | # Don't add coderefs to GetOptions |
213 | GetOptions( |
214 | 'v|verbose' => \$self->{verbose}, |
215 | 'f|failures' => \$self->{failures}, |
216 | 'l|lib' => \$self->{lib}, |
217 | 'b|blib' => \$self->{blib}, |
218 | 's|shuffle' => \$self->{shuffle}, |
219 | 'color!' => \$self->{color}, |
53bc175b |
220 | 'colour!' => \$self->{color}, |
27fc0087 |
221 | 'count!' => \$self->{show_count}, |
7f01fda6 |
222 | 'c' => \$self->{color}, |
41d86c6b |
223 | 'D|dry' => \$self->{dry}, |
f7c69158 |
224 | 'ext=s' => \$self->{extension}, |
7f01fda6 |
225 | 'harness=s' => \$self->{harness}, |
f7c69158 |
226 | 'ignore-exit' => \$self->{ignore_exit}, |
7f01fda6 |
227 | 'formatter=s' => \$self->{formatter}, |
228 | 'r|recurse' => \$self->{recurse}, |
229 | 'reverse' => \$self->{backwards}, |
230 | 'fork' => \$self->{fork}, |
231 | 'p|parse' => \$self->{parse}, |
232 | 'q|quiet' => \$self->{quiet}, |
233 | 'Q|QUIET' => \$self->{really_quiet}, |
234 | 'e|exec=s' => \$self->{exec}, |
235 | 'm|merge' => \$self->{merge}, |
236 | 'I=s@' => $self->{includes}, |
237 | 'M=s@' => $self->{modules}, |
238 | 'P=s@' => $self->{plugins}, |
239 | 'state=s@' => $self->{state}, |
240 | 'directives' => \$self->{directives}, |
241 | 'h|help|?' => \$self->{show_help}, |
242 | 'H|man' => \$self->{show_man}, |
243 | 'V|version' => \$self->{show_version}, |
244 | 'a|archive=s' => \$self->{archive}, |
245 | 'j|jobs=i' => \$self->{jobs}, |
246 | 'timer' => \$self->{timer}, |
247 | 'T' => \$self->{taint_fail}, |
248 | 't' => \$self->{taint_warn}, |
249 | 'W' => \$self->{warnings_fail}, |
250 | 'w' => \$self->{warnings_warn}, |
f7c69158 |
251 | 'rules=s@' => $self->{rules}, |
7f01fda6 |
252 | ) or croak('Unable to continue'); |
253 | |
254 | # Stash the remainder of argv for later |
255 | $self->{argv} = [@ARGV]; |
256 | } |
257 | |
258 | return; |
259 | } |
260 | |
261 | sub _first_pos { |
262 | my $want = shift; |
263 | for ( 0 .. $#_ ) { |
264 | return $_ if $_[$_] eq $want; |
265 | } |
266 | return; |
267 | } |
268 | |
7f01fda6 |
269 | sub _help { |
270 | my ( $self, $verbosity ) = @_; |
271 | |
272 | eval('use Pod::Usage 1.12 ()'); |
273 | if ( my $err = $@ ) { |
274 | die 'Please install Pod::Usage for the --help option ' |
275 | . '(or try `perldoc prove`.)' |
276 | . "\n ($@)"; |
277 | } |
278 | |
279 | Pod::Usage::pod2usage( { -verbose => $verbosity } ); |
280 | |
281 | return; |
282 | } |
283 | |
284 | sub _color_default { |
285 | my $self = shift; |
286 | |
287 | return -t STDOUT && !IS_WIN32; |
288 | } |
289 | |
290 | sub _get_args { |
291 | my $self = shift; |
292 | |
293 | my %args; |
294 | |
295 | if ( defined $self->color ? $self->color : $self->_color_default ) { |
296 | $args{color} = 1; |
297 | } |
27fc0087 |
298 | if ( !defined $self->show_count ) { |
299 | $args{show_count} = 1; |
300 | } |
301 | else { |
302 | $args{show_count} = $self->show_count; |
303 | } |
7f01fda6 |
304 | |
305 | if ( $self->archive ) { |
306 | $self->require_harness( archive => 'TAP::Harness::Archive' ); |
307 | $args{archive} = $self->archive; |
308 | } |
309 | |
310 | if ( my $jobs = $self->jobs ) { |
311 | $args{jobs} = $jobs; |
312 | } |
313 | |
314 | if ( my $fork = $self->fork ) { |
315 | $args{fork} = $fork; |
316 | } |
317 | |
318 | if ( my $harness_opt = $self->harness ) { |
319 | $self->require_harness( harness => $harness_opt ); |
320 | } |
321 | |
322 | if ( my $formatter = $self->formatter ) { |
323 | $args{formatter_class} = $formatter; |
324 | } |
325 | |
f7c69158 |
326 | if ( $self->ignore_exit ) { |
327 | $args{ignore_exit} = 1; |
328 | } |
329 | |
7f01fda6 |
330 | if ( $self->taint_fail && $self->taint_warn ) { |
331 | die '-t and -T are mutually exclusive'; |
332 | } |
333 | |
334 | if ( $self->warnings_fail && $self->warnings_warn ) { |
335 | die '-w and -W are mutually exclusive'; |
336 | } |
337 | |
338 | for my $a (qw( lib switches )) { |
339 | my $method = "_get_$a"; |
340 | my $val = $self->$method(); |
341 | $args{$a} = $val if defined $val; |
342 | } |
343 | |
344 | # Handle verbose, quiet, really_quiet flags |
345 | my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, ); |
346 | |
347 | my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 } |
348 | keys %verb_map; |
349 | |
350 | die "Only one of verbose, quiet or really_quiet should be specified\n" |
351 | if @verb_adj > 1; |
352 | |
353 | $args{verbosity} = shift @verb_adj || 0; |
354 | |
355 | for my $a (qw( merge failures timer directives )) { |
356 | $args{$a} = 1 if $self->$a(); |
357 | } |
358 | |
359 | $args{errors} = 1 if $self->parse; |
360 | |
361 | # defined but zero-length exec runs test files as binaries |
362 | $args{exec} = [ split( /\s+/, $self->exec ) ] |
363 | if ( defined( $self->exec ) ); |
364 | |
365 | if ( defined( my $test_args = $self->test_args ) ) { |
366 | $args{test_args} = $test_args; |
367 | } |
368 | |
f7c69158 |
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 | |
7f01fda6 |
382 | return ( \%args, $self->{harness_class} ); |
383 | } |
384 | |
385 | sub _find_module { |
386 | my ( $self, $class, @search ) = @_; |
387 | |
388 | croak "Bad module name $class" |
389 | unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; |
390 | |
391 | for my $pfx (@search) { |
392 | my $name = join( '::', $pfx, $class ); |
7f01fda6 |
393 | eval "require $name"; |
394 | return $name unless $@; |
395 | } |
396 | |
397 | eval "require $class"; |
398 | return $class unless $@; |
399 | return; |
400 | } |
401 | |
402 | sub _load_extension { |
403 | my ( $self, $class, @search ) = @_; |
404 | |
405 | my @args = (); |
406 | if ( $class =~ /^(.*?)=(.*)/ ) { |
407 | $class = $1; |
408 | @args = split( /,/, $2 ); |
409 | } |
410 | |
411 | if ( my $name = $self->_find_module( $class, @search ) ) { |
412 | $name->import(@args); |
413 | } |
414 | else { |
415 | croak "Can't load module $class"; |
416 | } |
417 | } |
418 | |
419 | sub _load_extensions { |
420 | my ( $self, $ext, @search ) = @_; |
421 | $self->_load_extension( $_, @search ) for @$ext; |
422 | } |
423 | |
424 | =head3 C<run> |
425 | |
426 | Perform whatever actions the command line args specified. The C<prove> |
427 | command line tool consists of the following code: |
428 | |
429 | use App::Prove; |
430 | |
431 | my $app = App::Prove->new; |
432 | $app->process_args(@ARGV); |
27fc0087 |
433 | exit( $app->run ? 0 : 1 ); # if you need the exit code |
7f01fda6 |
434 | |
435 | =cut |
436 | |
437 | sub run { |
438 | my $self = shift; |
439 | |
440 | if ( $self->show_help ) { |
441 | $self->_help(1); |
442 | } |
443 | elsif ( $self->show_man ) { |
444 | $self->_help(2); |
445 | } |
446 | elsif ( $self->show_version ) { |
447 | $self->print_version; |
448 | } |
41d86c6b |
449 | elsif ( $self->dry ) { |
450 | print "$_\n" for $self->_get_tests; |
451 | } |
7f01fda6 |
452 | else { |
453 | |
454 | $self->_load_extensions( $self->modules ); |
455 | $self->_load_extensions( $self->plugins, PLUGINS ); |
456 | |
53bc175b |
457 | local $ENV{TEST_VERBOSE} = 1 if $self->verbose; |
7f01fda6 |
458 | |
f7c69158 |
459 | return $self->_runtests( $self->_get_args, $self->_get_tests ); |
7f01fda6 |
460 | } |
461 | |
f7c69158 |
462 | return 1; |
7f01fda6 |
463 | } |
464 | |
41d86c6b |
465 | sub _get_tests { |
466 | my $self = shift; |
467 | |
27fc0087 |
468 | my $state = $self->state_manager; |
f7c69158 |
469 | my $ext = $self->extension; |
470 | $state->extension($ext) if defined $ext; |
41d86c6b |
471 | if ( defined( my $state_switch = $self->state ) ) { |
472 | $state->apply_switch(@$state_switch); |
473 | } |
474 | |
475 | my @tests = $state->get_tests( $self->recurse, @{ $self->argv } ); |
476 | |
477 | $self->_shuffle(@tests) if $self->shuffle; |
478 | @tests = reverse @tests if $self->backwards; |
479 | |
480 | return @tests; |
481 | } |
482 | |
7f01fda6 |
483 | sub _runtests { |
484 | my ( $self, $args, $harness_class, @tests ) = @_; |
485 | my $harness = $harness_class->new($args); |
486 | |
27fc0087 |
487 | my $state = $self->state_manager; |
488 | |
7f01fda6 |
489 | $harness->callback( |
490 | after_test => sub { |
27fc0087 |
491 | $state->observe_test(@_); |
492 | } |
493 | ); |
494 | |
495 | $harness->callback( |
496 | after_runtests => sub { |
497 | $state->commit(@_); |
7f01fda6 |
498 | } |
499 | ); |
500 | |
501 | my $aggregator = $harness->runtests(@tests); |
502 | |
27fc0087 |
503 | return !$aggregator->has_errors; |
7f01fda6 |
504 | } |
505 | |
506 | sub _get_switches { |
507 | my $self = shift; |
508 | my @switches; |
509 | |
510 | # notes that -T or -t must be at the front of the switches! |
511 | if ( $self->taint_fail ) { |
512 | push @switches, '-T'; |
513 | } |
514 | elsif ( $self->taint_warn ) { |
515 | push @switches, '-t'; |
516 | } |
517 | if ( $self->warnings_fail ) { |
518 | push @switches, '-W'; |
519 | } |
520 | elsif ( $self->warnings_warn ) { |
521 | push @switches, '-w'; |
522 | } |
523 | |
bd3ac2f1 |
524 | push @switches, split_shell( $ENV{HARNESS_PERL_SWITCHES} ); |
53bc175b |
525 | |
7f01fda6 |
526 | return @switches ? \@switches : (); |
527 | } |
528 | |
529 | sub _get_lib { |
530 | my $self = shift; |
531 | my @libs; |
532 | if ( $self->lib ) { |
533 | push @libs, 'lib'; |
534 | } |
535 | if ( $self->blib ) { |
536 | push @libs, 'blib/lib', 'blib/arch'; |
537 | } |
538 | if ( @{ $self->includes } ) { |
539 | push @libs, @{ $self->includes }; |
540 | } |
541 | |
542 | #24926 |
543 | @libs = map { File::Spec->rel2abs($_) } @libs; |
544 | |
545 | # Huh? |
546 | return @libs ? \@libs : (); |
547 | } |
548 | |
549 | sub _shuffle { |
550 | my $self = shift; |
551 | |
552 | # Fisher-Yates shuffle |
553 | my $i = @_; |
554 | while ($i) { |
555 | my $j = rand $i--; |
556 | @_[ $i, $j ] = @_[ $j, $i ]; |
557 | } |
558 | return; |
559 | } |
560 | |
561 | =head3 C<require_harness> |
562 | |
563 | Load a harness replacement class. |
564 | |
565 | $prove->require_harness($for => $class_name); |
566 | |
567 | =cut |
568 | |
569 | sub require_harness { |
570 | my ( $self, $for, $class ) = @_; |
571 | |
f7c69158 |
572 | my ($class_name) = $class =~ /^(\w+(?:::\w+)*)/; |
7f01fda6 |
573 | |
f7c69158 |
574 | # Emulate Perl's -MModule=arg1,arg2 behaviour |
575 | $class =~ s!^(\w+(?:::\w+)*)=(.*)$!$1 split(/,/,q{$2})!; |
576 | |
577 | eval("use $class;"); |
578 | die "$class_name is required to use the --$for feature: $@" if $@; |
579 | |
580 | $self->{harness_class} = $class_name; |
7f01fda6 |
581 | |
582 | return; |
583 | } |
584 | |
585 | =head3 C<print_version> |
586 | |
587 | Display the version numbers of the loaded L<TAP::Harness> and the |
588 | current Perl. |
589 | |
590 | =cut |
591 | |
592 | sub print_version { |
593 | my $self = shift; |
594 | printf( |
595 | "TAP::Harness v%s and Perl v%vd\n", |
596 | $TAP::Harness::VERSION, $^V |
597 | ); |
598 | |
599 | return; |
600 | } |
601 | |
602 | 1; |
603 | |
604 | # vim:ts=4:sw=4:et:sta |
605 | |
606 | __END__ |
607 | |
608 | =head2 Attributes |
609 | |
610 | After command line parsing the following attributes reflect the values |
611 | of the corresponding command line switches. They may be altered before |
612 | calling C<run>. |
613 | |
614 | =over |
615 | |
616 | =item C<archive> |
617 | |
618 | =item C<argv> |
619 | |
620 | =item C<backwards> |
621 | |
622 | =item C<blib> |
623 | |
624 | =item C<color> |
625 | |
626 | =item C<directives> |
627 | |
41d86c6b |
628 | =item C<dry> |
629 | |
7f01fda6 |
630 | =item C<exec> |
631 | |
f7c69158 |
632 | =item C<extension> |
633 | |
7f01fda6 |
634 | =item C<failures> |
635 | |
636 | =item C<fork> |
637 | |
638 | =item C<formatter> |
639 | |
640 | =item C<harness> |
641 | |
f7c69158 |
642 | =item C<ignore_exit> |
643 | |
7f01fda6 |
644 | =item C<includes> |
645 | |
646 | =item C<jobs> |
647 | |
648 | =item C<lib> |
649 | |
650 | =item C<merge> |
651 | |
652 | =item C<modules> |
653 | |
654 | =item C<parse> |
655 | |
656 | =item C<plugins> |
657 | |
658 | =item C<quiet> |
659 | |
660 | =item C<really_quiet> |
661 | |
662 | =item C<recurse> |
663 | |
f7c69158 |
664 | =item C<rules> |
665 | |
27fc0087 |
666 | =item C<show_count> |
667 | |
7f01fda6 |
668 | =item C<show_help> |
669 | |
670 | =item C<show_man> |
671 | |
672 | =item C<show_version> |
673 | |
674 | =item C<shuffle> |
675 | |
676 | =item C<state> |
677 | |
678 | =item C<taint_fail> |
679 | |
680 | =item C<taint_warn> |
681 | |
682 | =item C<test_args> |
683 | |
684 | =item C<timer> |
685 | |
686 | =item C<verbose> |
687 | |
688 | =item C<warnings_fail> |
689 | |
690 | =item C<warnings_warn> |
691 | |
692 | =back |