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 | |
53bc175b |
18 | Version 3.07 |
7f01fda6 |
19 | |
20 | =cut |
21 | |
53bc175b |
22 | $VERSION = '3.07'; |
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 |
57 | show_version test_args state |
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}, |
195 | 'harness=s' => \$self->{harness}, |
196 | 'formatter=s' => \$self->{formatter}, |
197 | 'r|recurse' => \$self->{recurse}, |
198 | 'reverse' => \$self->{backwards}, |
199 | 'fork' => \$self->{fork}, |
200 | 'p|parse' => \$self->{parse}, |
201 | 'q|quiet' => \$self->{quiet}, |
202 | 'Q|QUIET' => \$self->{really_quiet}, |
203 | 'e|exec=s' => \$self->{exec}, |
204 | 'm|merge' => \$self->{merge}, |
205 | 'I=s@' => $self->{includes}, |
206 | 'M=s@' => $self->{modules}, |
207 | 'P=s@' => $self->{plugins}, |
208 | 'state=s@' => $self->{state}, |
209 | 'directives' => \$self->{directives}, |
210 | 'h|help|?' => \$self->{show_help}, |
211 | 'H|man' => \$self->{show_man}, |
212 | 'V|version' => \$self->{show_version}, |
213 | 'a|archive=s' => \$self->{archive}, |
214 | 'j|jobs=i' => \$self->{jobs}, |
215 | 'timer' => \$self->{timer}, |
216 | 'T' => \$self->{taint_fail}, |
217 | 't' => \$self->{taint_warn}, |
218 | 'W' => \$self->{warnings_fail}, |
219 | 'w' => \$self->{warnings_warn}, |
220 | ) or croak('Unable to continue'); |
221 | |
222 | # Stash the remainder of argv for later |
223 | $self->{argv} = [@ARGV]; |
224 | } |
225 | |
226 | return; |
227 | } |
228 | |
229 | sub _first_pos { |
230 | my $want = shift; |
231 | for ( 0 .. $#_ ) { |
232 | return $_ if $_[$_] eq $want; |
233 | } |
234 | return; |
235 | } |
236 | |
237 | sub _exit { exit( $_[1] || 0 ) } |
238 | |
239 | sub _help { |
240 | my ( $self, $verbosity ) = @_; |
241 | |
242 | eval('use Pod::Usage 1.12 ()'); |
243 | if ( my $err = $@ ) { |
244 | die 'Please install Pod::Usage for the --help option ' |
245 | . '(or try `perldoc prove`.)' |
246 | . "\n ($@)"; |
247 | } |
248 | |
249 | Pod::Usage::pod2usage( { -verbose => $verbosity } ); |
250 | |
251 | return; |
252 | } |
253 | |
254 | sub _color_default { |
255 | my $self = shift; |
256 | |
257 | return -t STDOUT && !IS_WIN32; |
258 | } |
259 | |
260 | sub _get_args { |
261 | my $self = shift; |
262 | |
263 | my %args; |
264 | |
265 | if ( defined $self->color ? $self->color : $self->_color_default ) { |
266 | $args{color} = 1; |
267 | } |
268 | |
269 | if ( $self->archive ) { |
270 | $self->require_harness( archive => 'TAP::Harness::Archive' ); |
271 | $args{archive} = $self->archive; |
272 | } |
273 | |
274 | if ( my $jobs = $self->jobs ) { |
275 | $args{jobs} = $jobs; |
276 | } |
277 | |
278 | if ( my $fork = $self->fork ) { |
279 | $args{fork} = $fork; |
280 | } |
281 | |
282 | if ( my $harness_opt = $self->harness ) { |
283 | $self->require_harness( harness => $harness_opt ); |
284 | } |
285 | |
286 | if ( my $formatter = $self->formatter ) { |
287 | $args{formatter_class} = $formatter; |
288 | } |
289 | |
290 | if ( $self->taint_fail && $self->taint_warn ) { |
291 | die '-t and -T are mutually exclusive'; |
292 | } |
293 | |
294 | if ( $self->warnings_fail && $self->warnings_warn ) { |
295 | die '-w and -W are mutually exclusive'; |
296 | } |
297 | |
298 | for my $a (qw( lib switches )) { |
299 | my $method = "_get_$a"; |
300 | my $val = $self->$method(); |
301 | $args{$a} = $val if defined $val; |
302 | } |
303 | |
304 | # Handle verbose, quiet, really_quiet flags |
305 | my %verb_map = ( verbose => 1, quiet => -1, really_quiet => -2, ); |
306 | |
307 | my @verb_adj = grep {$_} map { $self->$_() ? $verb_map{$_} : 0 } |
308 | keys %verb_map; |
309 | |
310 | die "Only one of verbose, quiet or really_quiet should be specified\n" |
311 | if @verb_adj > 1; |
312 | |
313 | $args{verbosity} = shift @verb_adj || 0; |
314 | |
315 | for my $a (qw( merge failures timer directives )) { |
316 | $args{$a} = 1 if $self->$a(); |
317 | } |
318 | |
319 | $args{errors} = 1 if $self->parse; |
320 | |
321 | # defined but zero-length exec runs test files as binaries |
322 | $args{exec} = [ split( /\s+/, $self->exec ) ] |
323 | if ( defined( $self->exec ) ); |
324 | |
325 | if ( defined( my $test_args = $self->test_args ) ) { |
326 | $args{test_args} = $test_args; |
327 | } |
328 | |
329 | return ( \%args, $self->{harness_class} ); |
330 | } |
331 | |
332 | sub _find_module { |
333 | my ( $self, $class, @search ) = @_; |
334 | |
335 | croak "Bad module name $class" |
336 | unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; |
337 | |
338 | for my $pfx (@search) { |
339 | my $name = join( '::', $pfx, $class ); |
340 | print "$name\n"; |
341 | eval "require $name"; |
342 | return $name unless $@; |
343 | } |
344 | |
345 | eval "require $class"; |
346 | return $class unless $@; |
347 | return; |
348 | } |
349 | |
350 | sub _load_extension { |
351 | my ( $self, $class, @search ) = @_; |
352 | |
353 | my @args = (); |
354 | if ( $class =~ /^(.*?)=(.*)/ ) { |
355 | $class = $1; |
356 | @args = split( /,/, $2 ); |
357 | } |
358 | |
359 | if ( my $name = $self->_find_module( $class, @search ) ) { |
360 | $name->import(@args); |
361 | } |
362 | else { |
363 | croak "Can't load module $class"; |
364 | } |
365 | } |
366 | |
367 | sub _load_extensions { |
368 | my ( $self, $ext, @search ) = @_; |
369 | $self->_load_extension( $_, @search ) for @$ext; |
370 | } |
371 | |
372 | =head3 C<run> |
373 | |
374 | Perform whatever actions the command line args specified. The C<prove> |
375 | command line tool consists of the following code: |
376 | |
377 | use App::Prove; |
378 | |
379 | my $app = App::Prove->new; |
380 | $app->process_args(@ARGV); |
381 | $app->run; |
382 | |
383 | =cut |
384 | |
385 | sub run { |
386 | my $self = shift; |
387 | |
388 | if ( $self->show_help ) { |
389 | $self->_help(1); |
390 | } |
391 | elsif ( $self->show_man ) { |
392 | $self->_help(2); |
393 | } |
394 | elsif ( $self->show_version ) { |
395 | $self->print_version; |
396 | } |
397 | else { |
398 | |
399 | $self->_load_extensions( $self->modules ); |
400 | $self->_load_extensions( $self->plugins, PLUGINS ); |
401 | |
402 | my $state = $self->{_state}; |
403 | if ( defined( my $state_switch = $self->state ) ) { |
404 | $state->apply_switch(@$state_switch); |
405 | } |
406 | |
407 | my @tests = $state->get_tests( $self->recurse, @{ $self->argv } ); |
408 | |
409 | $self->_shuffle(@tests) if $self->shuffle; |
410 | @tests = reverse @tests if $self->backwards; |
53bc175b |
411 | local $ENV{TEST_VERBOSE} = 1 if $self->verbose; |
7f01fda6 |
412 | |
413 | $self->_runtests( $self->_get_args, @tests ); |
414 | } |
415 | |
416 | return; |
417 | } |
418 | |
419 | sub _runtests { |
420 | my ( $self, $args, $harness_class, @tests ) = @_; |
421 | my $harness = $harness_class->new($args); |
422 | |
423 | $harness->callback( |
424 | after_test => sub { |
425 | $self->{_state}->observe_test(@_); |
426 | } |
427 | ); |
428 | |
429 | my $aggregator = $harness->runtests(@tests); |
430 | |
431 | $self->_exit( $aggregator->has_problems ? 1 : 0 ); |
432 | |
433 | return; |
434 | } |
435 | |
436 | sub _get_switches { |
437 | my $self = shift; |
438 | my @switches; |
439 | |
440 | # notes that -T or -t must be at the front of the switches! |
441 | if ( $self->taint_fail ) { |
442 | push @switches, '-T'; |
443 | } |
444 | elsif ( $self->taint_warn ) { |
445 | push @switches, '-t'; |
446 | } |
447 | if ( $self->warnings_fail ) { |
448 | push @switches, '-W'; |
449 | } |
450 | elsif ( $self->warnings_warn ) { |
451 | push @switches, '-w'; |
452 | } |
453 | |
53bc175b |
454 | if ( defined( my $hps = $ENV{HARNESS_PERL_SWITCHES} ) ) { |
455 | push @switches, $hps; |
456 | } |
457 | |
7f01fda6 |
458 | return @switches ? \@switches : (); |
459 | } |
460 | |
461 | sub _get_lib { |
462 | my $self = shift; |
463 | my @libs; |
464 | if ( $self->lib ) { |
465 | push @libs, 'lib'; |
466 | } |
467 | if ( $self->blib ) { |
468 | push @libs, 'blib/lib', 'blib/arch'; |
469 | } |
470 | if ( @{ $self->includes } ) { |
471 | push @libs, @{ $self->includes }; |
472 | } |
473 | |
474 | #24926 |
475 | @libs = map { File::Spec->rel2abs($_) } @libs; |
476 | |
477 | # Huh? |
478 | return @libs ? \@libs : (); |
479 | } |
480 | |
481 | sub _shuffle { |
482 | my $self = shift; |
483 | |
484 | # Fisher-Yates shuffle |
485 | my $i = @_; |
486 | while ($i) { |
487 | my $j = rand $i--; |
488 | @_[ $i, $j ] = @_[ $j, $i ]; |
489 | } |
490 | return; |
491 | } |
492 | |
493 | =head3 C<require_harness> |
494 | |
495 | Load a harness replacement class. |
496 | |
497 | $prove->require_harness($for => $class_name); |
498 | |
499 | =cut |
500 | |
501 | sub require_harness { |
502 | my ( $self, $for, $class ) = @_; |
503 | |
504 | eval("require $class"); |
505 | die "$class is required to use the --$for feature: $@" if $@; |
506 | |
507 | $self->{harness_class} = $class; |
508 | |
509 | return; |
510 | } |
511 | |
512 | =head3 C<print_version> |
513 | |
514 | Display the version numbers of the loaded L<TAP::Harness> and the |
515 | current Perl. |
516 | |
517 | =cut |
518 | |
519 | sub print_version { |
520 | my $self = shift; |
521 | printf( |
522 | "TAP::Harness v%s and Perl v%vd\n", |
523 | $TAP::Harness::VERSION, $^V |
524 | ); |
525 | |
526 | return; |
527 | } |
528 | |
529 | 1; |
530 | |
531 | # vim:ts=4:sw=4:et:sta |
532 | |
533 | __END__ |
534 | |
535 | =head2 Attributes |
536 | |
537 | After command line parsing the following attributes reflect the values |
538 | of the corresponding command line switches. They may be altered before |
539 | calling C<run>. |
540 | |
541 | =over |
542 | |
543 | =item C<archive> |
544 | |
545 | =item C<argv> |
546 | |
547 | =item C<backwards> |
548 | |
549 | =item C<blib> |
550 | |
551 | =item C<color> |
552 | |
553 | =item C<directives> |
554 | |
555 | =item C<exec> |
556 | |
557 | =item C<failures> |
558 | |
559 | =item C<fork> |
560 | |
561 | =item C<formatter> |
562 | |
563 | =item C<harness> |
564 | |
565 | =item C<includes> |
566 | |
567 | =item C<jobs> |
568 | |
569 | =item C<lib> |
570 | |
571 | =item C<merge> |
572 | |
573 | =item C<modules> |
574 | |
575 | =item C<parse> |
576 | |
577 | =item C<plugins> |
578 | |
579 | =item C<quiet> |
580 | |
581 | =item C<really_quiet> |
582 | |
583 | =item C<recurse> |
584 | |
585 | =item C<show_help> |
586 | |
587 | =item C<show_man> |
588 | |
589 | =item C<show_version> |
590 | |
591 | =item C<shuffle> |
592 | |
593 | =item C<state> |
594 | |
595 | =item C<taint_fail> |
596 | |
597 | =item C<taint_warn> |
598 | |
599 | =item C<test_args> |
600 | |
601 | =item C<timer> |
602 | |
603 | =item C<verbose> |
604 | |
605 | =item C<warnings_fail> |
606 | |
607 | =item C<warnings_warn> |
608 | |
609 | =back |