File Coverage

blib/lib/Test/DependentModules.pm
Criterion Covered Total %
statement 85 271 31.3
branch 10 76 13.1
condition 1 21 4.7
subroutine 27 54 50.0
pod 3 3 100.0
total 126 425 29.6


line stmt bran cond sub pod time code
1             package Test::DependentModules;
2              
3 1     1   35816 use strict;
  1         3  
  1         27  
4 1     1   5 use warnings;
  1         2  
  1         27  
5 1     1   1174362 use autodie;
  1         541863  
  1         4  
6              
7             our $VERSION = '0.26';
8              
9             # CPAN::Reporter spits out random output we don't want, and we don't want to
10             # report these tests anyway.
11             BEGIN {
12             ## no critic (Variables::RequireLocalizedPunctuationVars)
13 1     1   6004 $INC{'CPAN/Reporter.pm'} = 0;
14             }
15              
16 1     1   943 use Capture::Tiny qw( capture );
  1         585623  
  1         79  
17 1     1   10 use Cwd qw( abs_path );
  1         2  
  1         42  
18 1     1   5 use Exporter qw( import );
  1         2  
  1         27  
19 1     1   5 use File::Path qw( rmtree );
  1         1  
  1         42  
20 1     1   5 use File::Spec;
  1         2  
  1         28  
21 1     1   4 use File::Temp qw( tempdir );
  1         2  
  1         48  
22 1     1   6 use File::chdir;
  1         1  
  1         82  
23 1     1   824 use IO::Handle::Util qw( io_from_write_cb );
  1         22769  
  1         10  
24 1     1   1371 use IPC::Run3 qw( run3 );
  1         17409  
  1         168  
25 1     1   966 use Log::Dispatch;
  1         14737  
  1         35  
26 1     1   280533 use MetaCPAN::Client;
  1         254269  
  1         33  
27 1     1   9 use Test::Builder;
  1         2  
  1         31  
28 1     1   6 use Try::Tiny;
  1         2  
  1         2862  
29              
30             our @EXPORT_OK = qw( test_all_dependents test_module test_modules );
31              
32             ## no critic (Variables::RequireLocalizedPunctuationVars)
33             $ENV{PERL5LIB} = join q{:}, ( $ENV{PERL5LIB} || q{} ),
34             File::Spec->catdir( _temp_lib_dir(), 'lib', 'perl5' );
35             $ENV{PERL_AUTOINSTALL} = '--defaultdeps';
36             $ENV{PERL_MM_USE_DEFAULT} = 1;
37             ## use critic
38              
39             my $Test = Test::Builder->new;
40              
41             sub test_all_dependents {
42 0     0 1 0 my $module = shift;
43 0         0 my $params = shift;
44              
45 0         0 _load_cpan();
46 0         0 _make_logs();
47              
48 0         0 my @deps = _get_deps( $module, $params );
49              
50 0         0 $Test->plan( tests => scalar @deps );
51              
52 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
53 0         0 test_modules(@deps);
54             }
55              
56             sub _get_deps {
57 0     0   0 my $module = shift;
58 0         0 my $params = shift;
59              
60 0         0 $module =~ s/::/-/g;
61              
62 0         0 my $rev_deps = MetaCPAN::Client->new->rev_deps($module);
63              
64             my $allow
65             = $params->{filter} ? $params->{filter}
66 0     0   0 : $params->{exclude} ? sub { $_[0] !~ /$params->{exclude}/ }
67 0 0   0   0 : sub {1};
  0 0       0  
68              
69 0         0 my @deps;
70 0         0 while ( my $dep = $rev_deps->next ) {
71 0         0 my $dist = $dep->distribution;
72              
73 0 0       0 next unless $allow->($dist);
74 0 0       0 next if $dist =~ /^(?:Task|Bundle)/;
75              
76 0         0 push @deps => $dist;
77             }
78              
79             ## no critic (Subroutines::ProhibitReturnSort)
80 0         0 return sort { lc $a cmp lc $b } @deps;
  0         0  
81             }
82              
83             sub test_modules {
84 0     0 1 0 _load_cpan();
85 0         0 _make_logs();
86              
87 0         0 my $parallel = 0;
88 0 0 0     0 if ( $ENV{PERL_TEST_DM_PROCESSES}
89             && $ENV{PERL_TEST_DM_PROCESSES} > 1 ) {
90              
91 0 0       0 if ( eval { require Parallel::ForkManager; 1; } ) {
  0         0  
  0         0  
92 0         0 $parallel = 1;
93             }
94             else {
95 0         0 warn
96             'Cannot run multiple processes without the Parallel::ForkManager module.';
97             }
98             }
99              
100 0 0       0 if ($parallel) {
101 0         0 _test_in_parallel(@_);
102             }
103             else {
104 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
105 0         0 for my $module (@_) {
106 0         0 test_module($module);
107             }
108             }
109             }
110              
111             sub _test_in_parallel {
112 0     0   0 my @modules = @_;
113              
114 0         0 my $pm = Parallel::ForkManager->new( $ENV{PERL_TEST_DM_PROCESSES} );
115              
116             $pm->run_on_finish(
117             sub {
118 0     0   0 shift; # pid
119 0         0 shift; # program exit code
120 0         0 shift; # ident
121 0         0 shift; # exit signal
122 0         0 shift; # core dump
123 0         0 my $results = shift;
124              
125 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
126 0         0 _test_report($results);
127             }
128 0         0 );
129              
130 0         0 for my $module (@_) {
131 0 0       0 $pm->start and next;
132              
133 0         0 local $Test::Builder::Level = $Test::Builder::Level + 1;
134 0         0 test_module( $module, $pm );
135             }
136              
137 0         0 $pm->wait_all_children;
138             }
139              
140             sub test_module {
141 0     0 1 0 my $name = shift;
142 0         0 my $pm = shift;
143              
144 0         0 _load_cpan();
145 0         0 _make_logs();
146              
147 0         0 $name =~ s/-/::/g;
148              
149 0         0 my $dist = _get_distro($name);
150 0 0       0 unless ($dist) {
151 0         0 _finish_test(
152             $pm,
153             {
154             name => $name,
155             skipped => qq{Could't find a distro for $name},
156             }
157             );
158 0         0 return;
159             }
160              
161 0         0 $Test->diag( 'Testing ' . $dist->base_id );
162              
163 0 0       0 unless ($dist) {
164 0         0 $name =~ s/::/-/g;
165 0 0       0 my $todo
166             = defined( $Test->todo )
167             ? ' (TODO: ' . $Test->todo . ')'
168             : q{};
169 0         0 my $summary = "FAIL${todo}: $name - ??? - ???";
170 0         0 my $output = "Could not find $name on CPAN\n";
171              
172 0         0 _finish_test(
173             $pm, {
174             name => $name,
175             passed => 0,
176             summary => $summary,
177             output => $output,
178             stderr => $output,
179             }
180             );
181 0         0 return;
182             }
183              
184 0         0 $name = $dist->base_id;
185              
186             my $success = try {
187 0     0   0 capture { _install_prereqs($dist) };
  0         0  
188 0         0 1;
189             }
190             catch {
191 0     0   0 local $Test::Builder::Level = $Test::Builder::Level + 1;
192 0         0 my $msg = "Installing prereqs for $name failed: $_";
193 0         0 $msg =~ s/\s*$//;
194 0         0 $msg =~ s/\n/\t/g;
195              
196 0         0 _finish_test(
197             $pm,
198             , {
199             name => $name,
200             skipped => $msg,
201             }
202             );
203 0         0 return;
204 0         0 };
205              
206 0 0       0 return unless $success;
207              
208 0         0 my ( $passed, $output, $stderr ) = _run_tests_for_dir( $dist->dir );
209              
210             # A lot of modules seem to have cargo-culted a diag() that looks like this
211             # ...
212             #
213             # Testing Foo::Bar 0.01, Perl 5.00801, /usr/bin/perl
214 0 0 0     0 $stderr = q{}
215             if defined $stderr && $stderr =~ /\A\# Testing [\w:]+ [^\n]+\Z/;
216              
217 0 0 0     0 my $status = $passed && $stderr ? 'WARN' : $passed ? 'PASS' : 'FAIL';
    0          
218 0 0       0 if ( my $reason = $Test->todo ) {
219 0         0 $status .= " (TODO: $reason)";
220             }
221              
222 0         0 my $summary
223             = "$status: $name - " . $dist->base_id . ' - ' . $dist->author->id;
224              
225 0         0 _finish_test(
226             $pm,
227             {
228             name => $name,
229             passed => $passed,
230             summary => $summary,
231             output => $output,
232             stderr => $stderr,
233             }
234             );
235             }
236              
237             sub _finish_test {
238 0     0   0 my $pm = shift;
239 0         0 my $results = shift;
240              
241 0 0       0 if ($pm) {
242 0         0 $pm->finish( 0, $results );
243             }
244             else {
245 0         0 local $Test::Builder::Level = $Test::Builder::Level + 2;
246 0         0 _test_report($results);
247             }
248             }
249              
250             ## no critic (Subroutines::ProhibitManyArgs)
251             sub _test_report {
252 0     0   0 my $results = shift;
253              
254 0 0       0 if ( $results->{skipped} ) {
255 0         0 _status_log("UNKNOWN: $results->{name} ($results->{skipped})\n");
256 0         0 _error_log("UNKNOWN: $results->{name} ($results->{skipped})\n");
257              
258 0         0 $Test->diag("Skipping $results->{name}: $results->{skipped}");
259 0         0 $Test->skip( $results->{skipped} );
260             }
261             else {
262 0         0 _status_log("$results->{summary}\n");
263 0         0 _error_log("$results->{summary}\n");
264              
265 0         0 $Test->ok( $results->{passed}, "$results->{name} passed all tests" );
266             }
267              
268 0 0 0     0 if ( $results->{passed} || $results->{skipped} ) {
269 0         0 _error_log("\n");
270             }
271             else {
272 0         0 _error_log( q{-} x 50 );
273 0         0 _error_log("\n");
274 0 0       0 _error_log("$results->{output}\n") if defined $results->{output};
275 0 0       0 _error_log("$results->{stderr}\n") if defined $results->{stderr};
276             }
277             }
278              
279             {
280             my %logs;
281              
282             sub _make_logs {
283 0 0   0   0 return if %logs;
284              
285             my $file_class = $ENV{PERL_TEST_DM_PROCESSES}
286 0 0 0     0 && $ENV{PERL_TEST_DM_PROCESSES} > 1 ? 'File::Locked' : 'File';
287              
288 0         0 for my $type (qw( status error prereq )) {
289 0         0 $logs{$type} = Log::Dispatch->new(
290             outputs => [
291             [
292             $file_class,
293             min_level => 'debug',
294             filename => _log_filename($type),
295             mode => 'append',
296             ],
297             ],
298             );
299             }
300             }
301              
302             sub _status_log {
303 0     0   0 $logs{status}->info(@_);
304             }
305              
306             sub _error_log {
307 0     0   0 $logs{error}->info(@_);
308             }
309              
310             sub _prereq_log {
311 0     0   0 $logs{prereq}->info(@_);
312             }
313             }
314              
315             sub _log_filename {
316 0     0   0 my $type = shift;
317              
318             return File::Spec->devnull
319 0 0       0 unless $ENV{PERL_TEST_DM_LOG_DIR};
320              
321             return File::Spec->catfile(
322             $ENV{PERL_TEST_DM_LOG_DIR},
323 0         0 'test-mydeps-' . $$ . q{-} . $type . '.log'
324             );
325             }
326              
327             sub _get_distro {
328 0     0   0 my $name = shift;
329              
330 0         0 my @mods = CPAN::Shell->expand( 'Module', $name );
331              
332 0 0       0 return unless @mods == 1;
333              
334 0         0 my $dist = $mods[0]->distribution;
335              
336 0 0       0 return unless $dist;
337              
338 0         0 $dist->get;
339              
340 0         0 return $dist;
341             }
342              
343             sub _install_prereqs {
344 0     0   0 my $dist = shift;
345 0   0     0 my $root_dist = shift || $dist->base_id;
346              
347 0         0 my $install_dir = _temp_lib_dir();
348              
349             ## no critic (Variables::RequireInitializationForLocalVars, Variables::ProhibitPackageVars)
350 0         0 local $CPAN::Config->{makepl_arg} .= " INSTALL_BASE=$install_dir";
351             local $CPAN::Config->{mbuild_install_arg}
352 0         0 .= " --install_base $install_dir";
353             ## use critic
354              
355 0         0 my $for_dist = $dist->base_id;
356              
357 0         0 for my $prereq ( $dist->unsat_prereq('configure_requires_later') ) {
358 0         0 _install_prereq( $prereq->[0], $for_dist, $root_dist );
359             }
360              
361 0         0 $dist->undelay;
362 0         0 $dist->make;
363              
364 0         0 for my $prereq ( $dist->unsat_prereq('later') ) {
365 0         0 _install_prereq( $prereq->[0], $for_dist, $root_dist );
366             }
367              
368 0         0 $dist->undelay;
369             }
370              
371             sub _install_prereq {
372 0     0   0 my $prereq = shift;
373 0         0 my $for_dist = shift;
374 0         0 my $root_dist = shift;
375              
376 0 0       0 return if $prereq eq 'perl';
377              
378 0         0 my $for = "for $for_dist";
379 0 0       0 if ( $for_dist ne $root_dist ) {
380 0         0 $for .= " (started with $root_dist)";
381             }
382              
383 0         0 my $dist = _get_distro($prereq);
384 0 0       0 if ( !$dist ) {
385 0         0 _prereq_log("Couldn't find $prereq $for\n");
386 0         0 next;
387             }
388              
389 0         0 _install_prereqs( $dist, $root_dist );
390              
391 0         0 my $installing = $dist->base_id;
392              
393 0         0 _prereq_log("Installing $installing $for\n");
394              
395             try {
396 0     0   0 $dist->notest;
397 0         0 $dist->install;
398             }
399             catch {
400 0     0   0 die "Installing $installing for $for_dist failed: $_";
401 0         0 };
402             }
403              
404             {
405             my $Dir;
406 1     1   6 BEGIN { $Dir = tempdir( CLEANUP => 1 ); }
407              
408             sub _temp_lib_dir {
409 1     1   15 return $Dir;
410             }
411             }
412              
413             sub _run_tests_for_dir {
414 7     7   1971987 my $dir = shift;
415              
416 7         152 local $CWD = $dir;
417              
418 7 100       751 if ( -e 'Build.PL' ) {
419             return
420 4 50       49 unless _run_commands(
421             ['./Build'],
422             );
423             }
424             else {
425             return
426 3 50       32 unless _run_commands(
427             ['make'],
428             );
429             }
430              
431 7         88 return _run_tests();
432             }
433              
434             sub _run_commands {
435 7     7   41 for my $cmd (@_) {
436 7         21 my $output;
437              
438             my $success = try {
439 7     7   525 run3( $cmd, \undef, \$output, \$output );
440             }
441             catch {
442 0     0   0 $output .= "Couldn't run @$cmd: $_";
443 0         0 return;
444 7         251 };
445              
446 7 50       2668076 return ( 0, $output )
447             unless $success;
448             }
449              
450 7         110 return 1;
451             }
452              
453             sub _run_tests {
454 7     7   57 my $output = q{};
455 7         31 my $error = q{};
456              
457             my $stderr = sub {
458 6     6   1127592 my $line = shift;
459              
460 6         11 $output .= $line;
461 6         24 $error .= $line;
462 7         112 };
463              
464 7         39 my $cmd;
465 7 100       257 if ( -e 'Build' ) {
    50          
466 4         24 $cmd = [qw( ./Build test )];
467             }
468             elsif ( -e 'Makefile' ) {
469 3         34 $cmd = [qw( make test )];
470             }
471             else {
472 0         0 return ( 0, "Cannot find a Build or Makefile file in $CWD" );
473             }
474              
475 7         18 my $passed;
476             try {
477 7     7   594 run3( $cmd, undef, \$output, $stderr );
478 7 100       3356869 if ( $? == 0 ) {
479 6   33     296 $passed = $output eq q{}
480             || $output =~ /Result: (?:PASS|NOTESTS)|No tests defined/;
481             }
482             }
483             catch {
484 0     0   0 $output .= "Couldn't run @$cmd: $_";
485 0         0 $error .= "Couldn't run @$cmd: $_";
486 7         173 };
487              
488 7         737 return ( $passed, $output, $error );
489             }
490              
491             {
492             my $LOADED_CPAN = 0;
493              
494             sub _load_cpan {
495             ## no critic (TestingAndDebugging::ProhibitNoWarnings)
496 1     1   1300 no warnings 'once';
  1         2  
  1         95  
497 0 0   0     return if $LOADED_CPAN;
498              
499 0           require CPAN;
500 0           require CPAN::Shell;
501              
502             ## no critic (InputOutput::RequireBriefOpen)
503 0           open my $fh, '>', File::Spec->devnull;
504              
505             {
506 1     1   5 no warnings 'redefine';
  1         2  
  1         332  
  0            
507 0     0     *CPAN::Shell::report_fh = sub {$fh};
  0            
508             }
509              
510             ## no critic (Variables::ProhibitPackageVars)
511 0           $CPAN::Be_Silent = 1;
512              
513 0           CPAN::HandleConfig->load;
514 0           CPAN::Shell::setup_output();
515 0           CPAN::Index->reload('force');
516              
517 0           $CPAN::Config->{test_report} = 0;
518 0           $CPAN::Config->{mbuildpl_arg} .= ' --quiet';
519 0           $CPAN::Config->{prerequisites_policy} = 'follow';
520 0           $CPAN::Config->{make_install_make_command} =~ s/^sudo //;
521 0           $CPAN::Config->{mbuild_install_build_command} =~ s/^sudo //;
522 0           $CPAN::Config->{make_install_arg} =~ s/UNINST=1//;
523 0           $CPAN::Config->{mbuild_install_arg} =~ s/--uninst\s+1//;
524              
525 0 0         if ( $ENV{PERL_TEST_DM_CPAN_VERBOSE} ) {
526 0     0     $fh = io_from_write_cb( sub { $Test->diag( $_[0] ) } );
  0            
527             }
528              
529 0           $LOADED_CPAN = 1;
530              
531 0           return;
532             }
533             }
534              
535             1;
536              
537             # ABSTRACT: Test all modules which depend on your module
538              
539             __END__