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