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