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