File Coverage

blib/lib/Test/Run/CmdLine/Prove.pm
Criterion Covered Total %
statement 131 201 65.1
branch 26 50 52.0
condition 4 18 22.2
subroutine 28 39 71.7
pod 2 2 100.0
total 191 310 61.6


line stmt bran cond sub pod time code
1             package Test::Run::CmdLine::Prove;
2              
3 1     1   20457 use strict;
  1         3  
  1         26  
4 1     1   5 use warnings;
  1         2  
  1         24  
5              
6 1     1   812 use Moose;
  1         470553  
  1         8  
7              
8             with 'MooseX::Getopt::Basic';
9              
10             has 'dry' => (
11             traits => ['Getopt'], is => "rw",
12             isa => "Bool", cmd_aliases => [qw(D)],
13             );
14              
15             has '_ext_regex' => (accessor => "ext_regex", is => "rw", isa => "RegexpRef");
16             has '_ext_regex_string' =>
17             (accessor => "ext_regex_string", is => "rw", isa => "Str")
18             ;
19             has 'recurse' => (traits => ['Getopt'], is => "rw",
20             isa => "Bool", cmd_aliases => [qw(r)],
21             );
22             has 'shuffle' => (
23             traits => ['Getopt'], is => "rw",
24             isa => "Bool", cmd_aliases => [qw(s)],
25             );
26             has 'Verbose' => (
27             traits => ['Getopt'], is => "rw",
28             isa => "Bool", cmd_aliases => [qw(v)],
29             );
30             has 'Debug' => (
31             traits => ['Getopt'], is => "rw",
32             isa => "Bool", cmd_aliases => [qw(d)],
33             );
34              
35             has '_Switches' => (accessor => "Switches", is => "rw", isa => "ArrayRef");
36             has 'Test_Interpreter' => (
37             traits => ['Getopt'], is => "rw",
38             isa => "Str", cmd_aliases => [qw(perl)],
39             );
40             has 'Timer' => (
41             traits => ['Getopt'], is => "rw",
42             isa => "Bool",
43             cmd_aliases => [qw(timer)],
44             );
45             has 'proto_includes' => (
46             traits => ['Getopt'],
47             is => "rw", isa => "ArrayRef",
48             cmd_aliases => [qw(I)],
49             default => sub { return []; },
50             );
51             has 'blib' => (
52             traits => ['Getopt'], is => "rw",
53             isa => "Bool", cmd_aliases => [qw(b)],
54             );
55              
56             has 'lib' => (
57             traits => ['Getopt'], is => "rw",
58             isa => "Bool", cmd_aliases => [qw(l)],
59             );
60              
61             has 'taint' => (
62             traits => ['Getopt'], is => "rw",
63             isa => "Bool", cmd_aliases => [qw(t)],
64             );
65              
66             has 'uc_taint' => (
67             traits => ['Getopt'], is => "rw",
68             isa => "Bool", cmd_aliases => [qw(T)],
69             );
70              
71             has 'help' => (
72             traits => ['Getopt'], is => "rw",
73             isa => "Bool", cmd_aliases => [qw(h ?)],
74             );
75              
76             has 'man' => (
77             traits => ['Getopt'], is => "rw",
78             isa => "Bool", cmd_aliases => [qw(H)],
79             );
80              
81             has 'version' => (
82             traits => ['Getopt'], is => "rw",
83             isa => "Bool", cmd_aliases => [qw(V)],
84             );
85              
86             has 'ext' => (
87             is => "rw", isa => "ArrayRef",
88             default => sub { return []; },
89             );
90              
91 1     1   7514 use MRO::Compat;
  1         2  
  1         23  
92              
93 1     1   838 use Test::Run::CmdLine::Iface;
  1         4  
  1         10  
94 1     1   1349 use Getopt::Long;
  1         11335  
  1         5  
95 1     1   1057 use Pod::Usage 1.12;
  1         57257  
  1         147  
96 1     1   12 use File::Spec;
  1         2  
  1         9  
97              
98 1     1   28 use vars qw($VERSION);
  1         1  
  1         2192  
99              
100             $VERSION = '0.0131';
101              
102              
103             =head1 NAME
104              
105             Test::Run::CmdLine::Prove - A Module for running tests from the command line
106              
107             =head1 SYNOPSIS
108              
109             use Test::Run::CmdLine::Prove;
110              
111             my $tester = Test::Run::CmdLine::Prove->new({'args' => [@ARGV]});
112              
113             $tester->run();
114              
115             =cut
116              
117             =begin removed_code
118              
119             around '_parse_argv' => sub {
120             my $orig = shift;
121             my $self = shift;
122              
123             my %params = $self->$orig(@_);
124             delete($params{'usage'});
125             return %params;
126             };
127              
128             =end removed_code
129              
130             =cut
131              
132             sub create
133             {
134 12     12 1 9710 my $class = shift;
135 12         23 my $args = shift;
136              
137 12         19 my @argv = @{$args->{'args'}};
  12         36  
138 12         26 my $env_switches = $args->{'env_switches'};
139              
140 12 50       36 if (defined($env_switches))
141             {
142 0         0 unshift @argv, split(" ", $env_switches);
143             }
144              
145 12         47 Getopt::Long::Configure( "no_ignore_case" );
146 12         401 Getopt::Long::Configure( "bundling" );
147              
148 12         293 my $self;
149             {
150             # Temporary workaround for MooseX::Getopt;
151 12         17 local @ARGV = @argv;
  12         34  
152 12         50 $self = $class->new_with_options(
153             argv => \@argv,
154             "no_ignore_case" => 1,
155             "bundling" => 1,
156             );
157             }
158              
159 12         20531 $self->_initial_process($args);
160              
161 12         42 return $self;
162             }
163              
164             sub _initial_process
165             {
166 12     12   29 my ($self, $args) = @_;
167              
168 12         66 $self->maybe::next::method($args);
169              
170 12         140 my @switches = ();
171              
172 12 50       460 if ($self->version())
173             {
174 0         0 $self->_print_version();
175 0         0 exit(0);
176             }
177              
178 12 50       439 if ($self->help())
179             {
180 0         0 $self->_usage(1);
181             }
182              
183 12 50       435 if ($self->man())
184             {
185 0         0 $self->_usage(2);
186             }
187              
188 12 50       432 if ($self->taint())
189             {
190 0         0 unshift @switches, "-t";
191             }
192              
193 12 50       445 if ($self->uc_taint())
194             {
195 0         0 unshift @switches, "-T";
196             }
197              
198 12         21 my @includes = @{$self->proto_includes()};
  12         466  
199              
200 12 50       432 if ($self->blib())
201             {
202 0         0 unshift @includes, ($self->_blibdirs());
203             }
204              
205             # Handle the lib include path
206 12 50       426 if ($self->lib())
207             {
208 0         0 unshift @includes, "lib";
209             }
210              
211 12         465 $self->proto_includes(\@includes);
212              
213 12         25 push @switches, (map { $self->_include_map($_) } @includes);
  0         0  
214              
215 12         529 $self->Switches(\@switches);
216              
217 12         19 $self->_set_ext([ @{$self->ext()} ]);
  12         431  
218              
219 12         32 return 0;
220             }
221              
222             sub _include_map
223             {
224 0     0   0 my $self = shift;
225 0         0 my $arg = shift;
226 0         0 my $ret = "-I$arg";
227 0 0 0     0 if (($arg =~ /\s/) &&
      0        
228             (! (($arg =~ /^"/) && ($arg =~ /"$/)) )
229             )
230             {
231 0         0 return "\"$ret\"";
232             }
233             else
234             {
235 0         0 return $ret;
236             }
237             }
238              
239             sub _print_version
240             {
241 0     0   0 my $self = shift;
242 0         0 printf("runprove v%s, using Test::Run v%s, Test::Run::CmdLine v%s and Perl v%s\n",
243             $VERSION,
244             $Test::Run::Obj::VERSION,
245             $Test::Run::CmdLine::VERSION,
246             $^V
247             );
248             }
249              
250             =head1 Interface Functions
251              
252             =head2 $prove = Test::Run::CmdLine::Prove->create({'args' => [@ARGV], 'env_switches' => $env_switches});
253              
254             Initializes a new object. C<'args'> is a keyed parameter that gives the
255             command line for the prove utility (as an array ref of strings).
256              
257             C<'env_switches'> is a keyed parameter that gives a string containing more
258             arguments, or undef if not wanted.
259              
260             =head2 $prove->run()
261              
262             Runs the tests.
263              
264             =cut
265              
266             sub run
267             {
268 0     0 1 0 my $self = shift;
269              
270 0         0 my $tests = $self->_get_test_files();
271              
272 0 0       0 if ($self->_should_run_tests($tests))
273             {
274 0         0 return $self->_actual_run_tests($tests);
275             }
276             else
277             {
278 0         0 return $self->_dont_run_tests($tests);
279             }
280             }
281              
282             sub _should_run_tests
283             {
284 0     0   0 my ($self, $tests) = @_;
285              
286 0         0 return scalar(@$tests);
287             }
288              
289             sub _actual_run_tests
290             {
291 0     0   0 my ($self, $tests) = @_;
292              
293 0 0       0 my $method = $self->dry() ? "_dry_run" : "_wet_run";
294              
295 0         0 return $self->$method($tests);
296             }
297              
298             sub _dont_run_tests
299             {
300 0     0   0 return 0;
301             }
302              
303             sub _wet_run
304             {
305 0     0   0 my $self = shift;
306 0         0 my $tests = shift;
307              
308 0         0 my $test_run =
309             Test::Run::CmdLine::Iface->new(
310             {
311             'test_files' => [@$tests],
312             'backend_params' => $self->_get_backend_params(),
313             }
314             );
315              
316 0         0 return $test_run->run();
317             }
318              
319             sub _dry_run
320             {
321 0     0   0 my $self = shift;
322 0         0 my $tests = shift;
323 0         0 print join("\n", @$tests, "");
324 0         0 return 0;
325             }
326              
327             # Stolen directly from blib.pm
328             sub _blibdirs {
329 0     0   0 my $self = shift;
330 0         0 my $dir = File::Spec->curdir;
331 0 0       0 if ($^O eq 'VMS') {
332 0         0 ($dir = VMS::Filespec::unixify($dir)) =~ s-/\z--;
333             }
334 0         0 my $archdir = "arch";
335 0 0       0 if ( $^O eq "MacOS" ) {
336             # Double up the MP::A so that it's not used only once.
337 0         0 $archdir = $MacPerl::Architecture = $MacPerl::Architecture;
338             }
339              
340 0         0 my $i = 5;
341 0         0 while ($i--) {
342 0         0 my $blib = File::Spec->catdir( $dir, "blib" );
343 0         0 my $blib_lib = File::Spec->catdir( $blib, "lib" );
344 0         0 my $blib_arch = File::Spec->catdir( $blib, $archdir );
345              
346 0 0 0     0 if ( -d $blib && -d $blib_arch && -d $blib_lib ) {
      0        
347 0         0 return ($blib_arch,$blib_lib);
348             }
349 0         0 $dir = File::Spec->catdir($dir, File::Spec->updir);
350             }
351 0         0 warn "Could not find blib dirs";
352 0         0 return;
353             }
354              
355             sub _get_backend_params_keys
356             {
357 1     1   5 return [qw(Verbose Debug Timer Test_Interpreter Switches)];
358             }
359              
360             sub _get_backend_params
361             {
362 1     1   8 my $self = shift;
363 1         5 my $ret = +{};
364 1         3 foreach my $key (@{$self->_get_backend_params_keys()})
  1         5  
365             {
366 5         193 my $value = $self->$key();
367 5 100       27 if (ref($value) eq "ARRAY")
368             {
369 1         5 $ret->{$key} = join(" ", @$value);
370             }
371             else
372             {
373 4 50       13 if (defined($value))
374             {
375 0         0 $ret->{$key} = $value;
376             }
377             }
378             }
379 1         8 return $ret;
380             }
381              
382             sub _usage
383             {
384 0     0   0 my $self = shift;
385 0         0 my $verbosity = shift;
386              
387 0         0 Pod::Usage::pod2usage(
388             {
389             '-verbose' => $verbosity,
390             '-exitval' => 0,
391             }
392             );
393              
394 0         0 return;
395             }
396              
397             sub _default_ext
398             {
399 12     12   17 my $self = shift;
400 12         20 my $ext = shift;
401 12 100       41 return (@$ext ? $ext : ["t"]);
402             }
403              
404             sub _normalize_extensions
405             {
406 12     12   18 my $self = shift;
407              
408 12         15 my $ext = shift;
409 12         21 $ext = [ map { split(/,/, $_) } @$ext ];
  13         47  
410 12         28 foreach my $e (@$ext)
411             {
412 17         40 $e =~ s{^\.}{};
413             }
414 12         25 return $ext;
415             }
416              
417             sub _set_ext
418             {
419 12     12   20 my $self = shift;
420 12         37 my $ext = $self->_default_ext(shift);
421              
422             $self->ext_regex_string('\.(?:' .
423 17         584 join("|", map { quotemeta($_) }
424 12         20 @{$self->_normalize_extensions($ext)}
  12         29  
425             )
426             . ')$'
427             );
428 12         41 $self->_set_ext_re();
429             }
430              
431             sub _set_ext_re
432             {
433 12     12   18 my $self = shift;
434 12         531 my $s = $self->ext_regex_string();
435 12         679 $self->ext_regex(qr/$s/);
436             }
437              
438             sub _post_process_test_files_list
439             {
440 7     7   11 my ($self, $list) = @_;
441 7 50       284 if ($self->shuffle())
442             {
443 0         0 return $self->_perform_shuffle($list);
444             }
445             else
446             {
447 7         30 return $list;
448             }
449             }
450              
451             sub _perform_shuffle
452             {
453 0     0   0 my ($self, $list) = @_;
454 0         0 my @ret = @$list;
455 0         0 my $i = @ret;
456 0         0 while ($i)
457             {
458 0         0 my $place = int(rand($i--));
459 0         0 @ret[$i,$place] = @ret[$place, $i];
460             }
461 0         0 return \@ret;
462             }
463              
464             sub _get_arguments
465             {
466 7     7   10 my $self = shift;
467 7         239 my $args = $self->extra_argv();
468 7 100 66     70 if (defined($args) && @$args)
469             {
470 6         16 return $args;
471             }
472             else
473             {
474 1         7 return [ File::Spec->curdir() ];
475             }
476             }
477              
478             sub _get_test_files
479             {
480 7     7   36 my $self = shift;
481             return
482             $self->_post_process_test_files_list(
483             [
484             map
485 8         21 { $self->_get_test_files_from_arg($_) }
486 7         13 @{$self->_get_arguments()}
  7         19  
487             ]
488             );
489             }
490              
491             sub _get_test_files_from_arg
492             {
493 8     8   12 my ($self, $arg) = @_;
494 8         287 return (map { $self->_get_test_files_from_globbed_entry($_) } glob($arg));
  8         20  
495             }
496              
497             sub _get_test_files_from_globbed_entry
498             {
499 8     8   17 my ($self, $entry) = @_;
500 8 100       98 if (-d $entry)
501             {
502 5         14 return $self->_get_test_files_from_dir($entry);
503             }
504             else
505             {
506 3         9 return $self->_get_test_files_from_file($entry);
507             }
508             }
509              
510             sub _get_test_files_from_file
511             {
512 3     3   6 my ($self, $entry) = @_;
513 3         18 return ($entry);
514             }
515              
516             sub _get_test_files_from_dir
517             {
518 11     11   18 my ($self, $path) = @_;
519 11 50       342 if (opendir my $dir, $path)
520             {
521 11         279 my @files = sort readdir($dir);
522 11         218 closedir($dir);
523             return
524 11         20 (map { $self->_get_test_files_from_dir_entry($path, $_) } @files);
  62         137  
525             }
526             else
527             {
528 0         0 warn "$path: $!\n";
529 0         0 return ();
530             }
531             }
532              
533             sub _should_ignore_dir_entry
534             {
535 62     62   84 my ($self, $dir, $file) = @_;
536             return
537             (
538 62   66     739 ($file eq File::Spec->updir()) ||
539             ($file eq File::Spec->curdir()) ||
540             ($file eq ".svn") ||
541             ($file eq "CVS")
542             );
543             }
544              
545             sub _get_test_files_from_dir_entry
546             {
547 62     62   110 my ($self, $dir, $file) = @_;
548 62 100       111 if ($self->_should_ignore_dir_entry($dir, $file))
549             {
550 22         54 return ();
551             }
552 40         344 my $path = File::Spec->catfile($dir, $file);
553 40 100       581 if (-d $path)
554             {
555 6         18 return $self->_get_test_files_from_dir_path($path);
556             }
557             else
558             {
559 34         73 return $self->_get_test_files_from_file_path($path);
560             }
561             }
562              
563             sub _get_test_files_from_dir_path
564             {
565 6     6   7 my ($self, $path) = @_;
566 6 50       223 if ($self->recurse())
567             {
568 6         18 return $self->_get_test_files_from_dir($path);
569             }
570             else
571             {
572 0         0 return ();
573             }
574             }
575              
576             sub _get_test_files_from_file_path
577             {
578 34     34   61 my ($self, $path) = @_;
579 34 100       1425 if ($path =~ $self->ext_regex())
580             {
581 30         146 return ($path);
582             }
583             else
584             {
585 4         18 return ();
586             }
587             }
588              
589             =head1 AUTHOR
590              
591             Shlomi Fish, L<http://www.shlomifish.org/> .
592              
593             =head1 BUGS
594              
595             Please report any bugs or feature requests to
596             C<bug-test-run-cmdline@rt.cpan.org>, or through the web interface at
597             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Run-CmdLine>.
598             I will be notified, and then you'll automatically be notified of progress on
599             your bug as I make changes.
600              
601             =head1 ACKNOWLEDGEMENTS
602              
603             =head1 COPYRIGHT & LICENSE
604              
605             Copyright 2005 Shlomi Fish, all rights reserved.
606              
607             This program is released under the MIT X11 License.
608              
609             =cut
610              
611             1;