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