File Coverage

lib/CPANPLUS/Internals/Report.pm
Criterion Covered Total %
statement 24 164 14.6
branch 0 90 0.0
condition 0 26 0.0
subroutine 8 13 61.5
pod n/a
total 32 293 10.9


line stmt bran cond sub pod time code
1             package CPANPLUS::Internals::Report;
2              
3 15     15   231 use strict;
  15         243  
  15         237  
4              
5 15     15   365 use CPANPLUS::Error;
  15         173  
  15         283  
6 15     15   234 use CPANPLUS::Internals::Constants;
  15         252  
  15         342  
7 15     15   672 use CPANPLUS::Internals::Constants::Report;
  15         159  
  15         414  
8              
9 15     15   284 use Data::Dumper;
  15         155  
  15         399  
10              
11 15     15   255 use Params::Check qw[check];
  15         164  
  15         298  
12 15     15   300 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
  15         150  
  15         274  
13 15     15   252 use Module::Load::Conditional qw[can_load];
  15         156  
  15         286  
14              
15             $Params::Check::VERBOSE = 1;
16              
17             ### for the version ###
18             require CPANPLUS::Internals;
19              
20             =head1 NAME
21            
22             CPANPLUS::Internals::Report
23            
24             =head1 SYNOPSIS
25            
26             ### enable test reporting
27             $cb->configure_object->set_conf( cpantest => 1 );
28            
29             ### set custom mx host, shouldn't normally be needed
30             $cb->configure_object->set_conf( cpantest_mx => 'smtp.example.com' );
31            
32             =head1 DESCRIPTION
33            
34             This module provides all the functionality to send test reports to
35             C<http://testers.cpan.org> using the C<Test::Reporter> module.
36            
37             All methods will be called automatically if you have C<CPANPLUS>
38             configured to enable test reporting (see the C<SYNOPSIS>).
39            
40             =head1 METHODS
41            
42             =head2 $bool = $cb->_have_query_report_modules
43            
44             This function checks if all the required modules are here for querying
45             reports. It returns true and loads them if they are, or returns false
46             otherwise.
47            
48             =head2 $bool = $cb->_have_send_report_modules
49            
50             This function checks if all the required modules are here for sending
51             reports. It returns true and loads them if they are, or returns false
52             otherwise.
53            
54             =cut
55             {   my $query_list = {
56                     LWP => '0.0',
57                     'LWP::UserAgent' => '0.0',
58                     'HTTP::Request' => '0.0',
59                     URI => '0.0',
60                     YAML => '0.0',
61                 };
62              
63                 my $send_list = {
64                     %$query_list,
65                     'Test::Reporter' => 1.27,
66                 };
67              
68                 sub _have_query_report_modules {
69 0     0             my $self = shift;
70 0                   my $conf = $self->configure_object;
71 0                   my %hash = @_;
72              
73 0                   my $tmpl = {
74                         verbose => { default => $conf->get_conf('verbose') },
75                     };
76              
77 0 0                 my $args = check( $tmpl, \%hash ) or return;
78              
79 0 0                 return can_load( modules => $query_list, verbose => $args->{verbose} )
80                             ? 1
81                             : 0;
82                 }
83              
84                 sub _have_send_report_modules {
85 0     0             my $self = shift;
86 0                   my $conf = $self->configure_object;
87 0                   my %hash = @_;
88              
89 0                   my $tmpl = {
90                         verbose => { default => $conf->get_conf('verbose') },
91                     };
92              
93 0 0                 my $args = check( $tmpl, \%hash ) or return;
94              
95 0 0                 return can_load( modules => $send_list, verbose => $args->{verbose} )
96                             ? 1
97                             : 0;
98                 }
99             }
100              
101             =head2 @list = $cb->_query_report( module => $modobj, [all_versions => BOOL, verbose => BOOL] )
102            
103             This function queries the CPAN testers database at
104             I<http://testers.cpan.org/> for test results of specified module objects,
105             module names or distributions.
106            
107             The optional argument C<all_versions> controls whether all versions of
108             a given distribution should be grabbed. It defaults to false
109             (fetching only reports for the current version).
110            
111             Returns the a list with the following data structures (for CPANPLUS
112             version 0.042) on success, or false on failure:
113            
114             {
115             'grade' => 'PASS',
116             'dist' => 'CPANPLUS-0.042',
117             'platform' => 'i686-pld-linux-thread-multi'
118             },
119             {
120             'grade' => 'PASS',
121             'dist' => 'CPANPLUS-0.042',
122             'platform' => 'i686-linux-thread-multi'
123             },
124             {
125             'grade' => 'FAIL',
126             'dist' => 'CPANPLUS-0.042',
127             'platform' => 'cygwin-multi-64int',
128             'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371'
129             },
130             {
131             'grade' => 'FAIL',
132             'dist' => 'CPANPLUS-0.042',
133             'platform' => 'i586-linux',
134             'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396'
135             },
136            
137             The status of the test can be one of the following:
138             UNKNOWN, PASS, FAIL or NA (not applicable).
139            
140             =cut
141              
142             sub _query_report {
143 0     0         my $self = shift;
144 0               my $conf = $self->configure_object;
145 0               my %hash = @_;
146              
147 0               my($mod, $verbose, $all);
148 0               my $tmpl = {
149                     module => { required => 1, allow => IS_MODOBJ,
150                                             store => \$mod },
151                     verbose => { default => $conf->get_conf('verbose'),
152                                             store => \$verbose },
153                     all_versions => { default => 0, store => \$all },
154                 };
155              
156 0 0             check( $tmpl, \%hash ) or return;
157              
158             ### check if we have the modules we need for querying
159 0 0             return unless $self->_have_query_report_modules( verbose => 1 );
160              
161             ### new user agent ###
162 0               my $ua = LWP::UserAgent->new;
163 0               $ua->agent( CPANPLUS_UA->() );
164              
165             ### set proxies if we have them ###
166 0               $ua->env_proxy();
167              
168 0               my $url = TESTERS_URL->($mod->package_name);
169 0               my $req = HTTP::Request->new( GET => $url);
170              
171 0               msg( loc("Fetching: '%1'", $url), $verbose );
172              
173 0               my $res = $ua->request( $req );
174              
175 0 0             unless( $res->is_success ) {
176 0                   error( loc( "Fetching report for '%1' failed: %2",
177                                 $url, $res->message ) );
178 0                   return;
179                 }
180              
181 0               my $aref = YAML::Load( $res->content );
182              
183 0               my $dist = $mod->package_name .'-'. $mod->package_version;
184              
185 0               my @rv;
186 0               for my $href ( @$aref ) {
187 0 0 0               next unless $all or defined $href->{'distversion'} &&
      0        
188                                         $href->{'distversion'} eq $dist;
189              
190 0 0                 push @rv, { platform => $href->{'platform'},
191                                 grade => $href->{'action'},
192                                 dist => $href->{'distversion'},
193                                 ( $href->{'action'} eq 'FAIL'
194                                     ? (details => TESTERS_DETAILS_URL->($mod->package_name))
195                                     : ()
196                                 ) };
197                 }
198              
199 0 0             return @rv if @rv;
200 0               return;
201             }
202              
203             =pod
204            
205             =head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, dontcc => BOOL, verbose => BOOL, force => BOOL]);
206            
207             This function sends a testers report to C<cpan-testers@perl.org> for a
208             particular distribution.
209             It returns true on success, and false on failure.
210            
211             It takes the following options:
212            
213             =over 4
214            
215             =item module
216            
217             The module object of this particular distribution
218            
219             =item buffer
220            
221             The output buffer from the 'make/make test' process
222            
223             =item failed
224            
225             Boolean indicating if the 'make/make test' went wrong
226            
227             =item save
228            
229             Boolean indicating if the report should be saved locally instead of
230             mailed out. If provided, this function will return the location the
231             report was saved to, rather than a simple boolean 'TRUE'.
232            
233             Defaults to false.
234            
235             =item address
236            
237             The email address to mail the report for. You should never need to
238             override this, but it might be useful for debugging purposes.
239            
240             Defaults to C<cpan-testers@perl.org>.
241            
242             =item dontcc
243            
244             Boolean indicating whether or not we should Cc: the author. If false,
245             previous error reports are inspected and checked if the author should
246             be mailed. If set to true, these tests are skipped and the author is
247             definitely not Cc:'d.
248             You should probably not change this setting.
249            
250             Defaults to false.
251            
252             =item verbose
253            
254             Boolean indicating on whether or not to be verbose.
255            
256             Defaults to your configuration settings
257            
258             =item force
259            
260             Boolean indicating whether to force the sending, even if the max
261             amount of reports for fails have already been reached, or if you
262             may already have sent it before.
263            
264             Defaults to your configuration settings
265            
266             =back
267            
268             =cut
269              
270             sub _send_report {
271 0     0         my $self = shift;
272 0               my $conf = $self->configure_object;
273 0               my %hash = @_;
274              
275             ### do you even /have/ test::reporter? ###
276 0 0             unless( $self->_have_send_report_modules(verbose => 1) ) {
277 0                   error( loc( "You don't have '%1' (or modules required by '%2') ".
278                                 "installed, you cannot report test results.",
279                                 'Test::Reporter', 'Test::Reporter' ) );
280 0                   return;
281                 }
282              
283             ### check arguments ###
284 0               my ($buffer, $failed, $mod, $verbose, $force, $address, $save, $dontcc,
285                     $tests_skipped );
286 0               my $tmpl = {
287                         module => { required => 1, store => \$mod, allow => IS_MODOBJ },
288                         buffer => { required => 1, store => \$buffer },
289                         failed => { required => 1, store => \$failed },
290                         address => { default => CPAN_TESTERS_EMAIL, store => \$address },
291                         save => { default => 0, store => \$save },
292                         dontcc => { default => 0, store => \$dontcc },
293                         verbose => { default => $conf->get_conf('verbose'),
294                                         store => \$verbose },
295                         force => { default => $conf->get_conf('force'),
296                                         store => \$force },
297                         tests_skipped
298                                 => { default => 0, store => \$tests_skipped },
299                 };
300              
301 0 0             check( $tmpl, \%hash ) or return;
302              
303             ### get the data to fill the email with ###
304 0               my $name = $mod->module;
305 0               my $dist = $mod->package_name . '-' . $mod->package_version;
306 0               my $author = $mod->author->author;
307 0   0           my $email = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author );
308 0   0           my $cp_conf = $conf->get_conf('cpantest') || '';
309 0               my $int_ver = $CPANPLUS::Internals::VERSION;
310              
311              
312             ### determine the grade now ###
313              
314 0               my $grade;
315             ### check if this is a platform specific module ###
316             ### if we failed the test, there may be reasons why
317             ### an 'NA' might have to be insted
318 0 0             if ( $failed ) {
319 0 0                 unless( RELEVANT_TEST_RESULT->($mod) ) {
    0          
    0          
    0          
320 0                       msg(loc(
321                             "'%1' is a platform specific module, and the test results on".
322                             " your platform are not relevant --sending N/A grade.",
323                             $name), $verbose);
324                     
325 0                       $grade = GRADE_NA;
326                     
327                     } elsif ( UNSUPPORTED_OS->( $buffer ) ) {
328 0                       msg(loc(
329                             "'%1' is a platform specific module, and the test results on".
330                             " your platform are not relevant --sending N/A grade.",
331                             $name), $verbose);
332                     
333 0                       $grade = GRADE_NA;
334                     
335             ### you dont have a high enough perl version?
336                     } elsif ( PERL_VERSION_TOO_LOW->( $buffer ) ) {
337 0                       msg(loc("'%1' requires a higher version of perl than your current ".
338                                 "version -- sending N/A grade.", $name), $verbose);
339                     
340 0                       $grade = GRADE_NA;
341              
342             ### perhaps where were no tests...
343             ### see if the thing even had tests ###
344                     } elsif ( NO_TESTS_DEFINED->( $buffer ) ) {
345 0                       $grade = GRADE_UNKNOWN;
346              
347                     } else {
348                         
349 0                       $grade = GRADE_FAIL;
350                     }
351              
352             ### if we got here, it didn't fail and tests were present.. so a PASS
353             ### is in order
354                 } else {
355 0                   $grade = GRADE_PASS;
356                 }
357              
358             ### so an error occurred, let's see what stage it went wrong in ###
359 0               my $message;
360 0 0 0           if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) {
    0          
361              
362             ### return if one or more missing external libraries
363 0 0                 if( my @missing = MISSING_EXTLIBS_LIST->($buffer) ) {
364 0                       msg(loc("Not sending test report - " .
365                                 "external libraries not pre-installed"));
366 0                       return 1;
367                     }
368              
369             ### will be 'fetch', 'make', 'test', 'install', etc ###
370 0                   my $stage = TEST_FAIL_STAGE->($buffer);
371              
372             ### return if we're only supposed to report make_test failures ###
373 0 0 0               return 1 if $cp_conf =~ /\bmaketest_only\b/i
374                                 and ($stage !~ /\btest\b/);
375              
376             ### the header
377 0                   $message = REPORT_MESSAGE_HEADER->( $int_ver, $author );
378              
379             ### the bit where we inform what went wrong
380 0                   $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );
381              
382             ### was it missing prereqs? ###
383 0 0                 if( my @missing = MISSING_PREREQS_LIST->($buffer) ) {
384 0 0                     if(!$self->_verify_missing_prereqs(
385                                             module => $mod,
386                                             missing => \@missing
387                                     )) {
388 0                           msg(loc("Not sending test report - " .
389                                     "bogus missing prerequisites report"));
390 0                           return 1;
391                         }
392 0                       $message .= REPORT_MISSING_PREREQS->($author,$email,@missing);
393                     }
394              
395             ### was it missing test files? ###
396 0 0                 if( NO_TESTS_DEFINED->($buffer) ) {
397 0                       $message .= REPORT_MISSING_TESTS->();
398                     }
399              
400             ### add a list of what modules have been loaded of your prereqs list
401 0                   $message .= REPORT_LOADED_PREREQS->($mod);
402              
403             ### the footer
404 0                   $message .= REPORT_MESSAGE_FOOTER->();
405              
406             ### it may be another grade than fail/unknown.. may be worth noting
407             ### that tests got skipped, since the buffer is not added in
408                 } elsif ( $tests_skipped ) {
409 0                   $message .= REPORT_TESTS_SKIPPED->();
410                 }
411              
412             ### if it failed, and that already got reported, we're not cc'ing the
413             ### author. Also, 'dont_cc' might be in the config, so check this;
414 0               my $dont_cc_author = $dontcc;
415              
416 0 0             unless( $dont_cc_author ) {
417 0 0                 if( $cp_conf =~ /\bdont_cc\b/i ) {
    0          
    0          
418 0                       $dont_cc_author++;
419              
420                     } elsif ( $grade eq GRADE_PASS ) {
421 0                       $dont_cc_author++
422              
423                     } elsif( $grade eq GRADE_FAIL ) {
424 0                       my @already_sent =
425                             $self->_query_report( module => $mod, verbose => $verbose );
426              
427             ### if we can't fetch it, we'll just assume no one
428             ### mailed him yet
429 0                       my $count = 0;
430 0 0                     if( @already_sent ) {
431 0                           for my $href (@already_sent) {
432 0 0                             $count++ if uc $href->{'grade'} eq uc GRADE_FAIL;
433                             }
434                         }
435              
436 0 0 0                   if( $count > MAX_REPORT_SEND and !$force) {
437 0                           msg(loc("'%1' already reported for '%2', ".
438                                     "not cc-ing the author",
439                                     GRADE_FAIL, $dist ), $verbose );
440 0                           $dont_cc_author++;
441                         }
442                     }
443                 }
444              
445             ### reporter object ###
446 0               my $reporter = Test::Reporter->new(
447                                     grade => $grade,
448                                     distribution => $dist,
449                                     via => "CPANPLUS $int_ver",
450                                     debug => $conf->get_conf('debug'),
451                                 );
452                                 
453             ### set a custom mx, if requested
454 0 0             $reporter->mx( [ $conf->get_conf('cpantest_mx') ] )
455                     if $conf->get_conf('cpantest_mx');
456              
457             ### set the from address ###
458 0 0             $reporter->from( $conf->get_conf('email') )
459                     if $conf->get_conf('email') !~ /\@example\.\w+$/i;
460              
461             ### give the user a chance to programattically alter the message
462 0               $message = $self->_callbacks->munge_test_report->($mod, $message, $grade);
463              
464             ### add the body if we have any ###
465 0 0 0           $reporter->comments( $message ) if defined $message && length $message;
466              
467             ### do a callback to ask if we should send the report
468 0 0             unless ($self->_callbacks->send_test_report->($mod, $grade)) {
469 0                   msg(loc("Ok, not sending test report"));
470 0                   return 1;
471                 }
472              
473             ### do a callback to ask if we should edit the report
474 0 0             if ($self->_callbacks->edit_test_report->($mod, $grade)) {
475             ### test::reporter 1.20 and lower don't have a way to set
476             ### the preferred editor with a method call, but it does
477             ### respect your env variable, so let's set that.
478 0 0                 local $ENV{VISUAL} = $conf->get_program('editor')
479                                             if $conf->get_program('editor');
480              
481 0                   $reporter->edit_comments;
482                 }
483              
484             ### people to mail ###
485 0               my @inform;
486             #push @inform, $email unless $dont_cc_author;
487              
488             ### allow to be overridden, but default to the normal address ###
489 0               $reporter->address( $address );
490              
491             ### should we save it locally? ###
492 0 0             if( $save ) {
    0          
493 0 0                 if( my $file = $reporter->write() ) {
494 0                       msg(loc("Successfully wrote report for '%1' to '%2'",
495                                 $dist, $file), $verbose);
496 0                       return $file;
497              
498                     } else {
499 0                       error(loc("Failed to write report for '%1'", $dist));
500 0                       return;
501                     }
502              
503             ### should we send it to a bunch of people? ###
504             ### XXX should we do an 'already sent' check? ###
505                 } elsif( $reporter->send( @inform ) ) {
506 0                   msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist),
507                         $verbose);
508 0                   return 1;
509              
510             ### something broke :( ###
511                 } else {
512 0                   error(loc("Could not send '%1' report for '%2': %3",
513                             $grade, $dist, $reporter->errstr));
514 0                   return;
515                 }
516             }
517              
518             sub _verify_missing_prereqs {
519 0     0         my $self = shift;
520 0               my %hash = @_;
521              
522             ### check arguments ###
523 0               my ($mod, $missing);
524 0               my $tmpl = {
525                         module => { required => 1, store => \$mod },
526                         missing => { required => 1, store => \$missing },
527                 };
528              
529 0 0             check( $tmpl, \%hash ) or return;
530              
531                 
532 0               my %missing = map {$_ => 1} @$missing;
  0            
533 0               my $conf = $self->configure_object;
534 0               my $extract = $mod->status->extract;
535              
536             ### Read pre-requisites from Makefile.PL or Build.PL (if there is one),
537             ### of the form:
538             ### 'PREREQ_PM' => {
539             ### 'Compress::Zlib' => '1.20',
540             ### 'Test::More' => 0,
541             ### },
542             ### Build.PL uses 'requires' instead of 'PREREQ_PM'.
543              
544 0               my @search;
545 0 0             push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->());
546 0 0             push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->());
547              
548 0               for my $file ( @search ) {
549 0 0 0               if(-e $file and -r $file) {
550 0                       my $slurp = $self->_get_file_contents(file => $file);
551 0                       my ($prereq) =
552                             ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s);
553 0                       my @prereq =
554                             ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg);
555 0                       delete $missing{$_} for(@prereq);
  0            
556                     }
557                 }
558              
559 0 0             return 1 if(keys %missing); # There ARE missing prerequisites
560 0               return; # All prerequisites accounted for
561             }
562              
563             1;
564              
565              
566             # Local variables:
567             # c-indentation-style: bsd
568             # c-basic-offset: 4
569             # indent-tabs-mode: nil
570             # End:
571             # vim: expandtab shiftwidth=4:
572