Commit | Line | Data |
6aaee015 |
1 | package CPANPLUS::Internals::Report; |
2 | |
3 | use strict; |
4 | |
5 | use CPANPLUS::Error; |
6 | use CPANPLUS::Internals::Constants; |
7 | use CPANPLUS::Internals::Constants::Report; |
8 | |
9 | use Data::Dumper; |
10 | |
11 | use Params::Check qw[check]; |
12 | use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext'; |
13 | use Module::Load::Conditional qw[can_load]; |
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 | my $self = shift; |
70 | my $conf = $self->configure_object; |
71 | my %hash = @_; |
72 | |
73 | my $tmpl = { |
74 | verbose => { default => $conf->get_conf('verbose') }, |
75 | }; |
76 | |
77 | my $args = check( $tmpl, \%hash ) or return; |
78 | |
79 | return can_load( modules => $query_list, verbose => $args->{verbose} ) |
80 | ? 1 |
81 | : 0; |
82 | } |
83 | |
84 | sub _have_send_report_modules { |
85 | my $self = shift; |
86 | my $conf = $self->configure_object; |
87 | my %hash = @_; |
88 | |
89 | my $tmpl = { |
90 | verbose => { default => $conf->get_conf('verbose') }, |
91 | }; |
92 | |
93 | my $args = check( $tmpl, \%hash ) or return; |
94 | |
95 | 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 | my $self = shift; |
144 | my $conf = $self->configure_object; |
145 | my %hash = @_; |
146 | |
147 | my($mod, $verbose, $all); |
148 | 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 | check( $tmpl, \%hash ) or return; |
157 | |
158 | ### check if we have the modules we need for querying |
159 | return unless $self->_have_query_report_modules( verbose => 1 ); |
160 | |
161 | ### new user agent ### |
162 | my $ua = LWP::UserAgent->new; |
163 | $ua->agent( CPANPLUS_UA->() ); |
164 | |
165 | ### set proxies if we have them ### |
166 | $ua->env_proxy(); |
167 | |
168 | my $url = TESTERS_URL->($mod->package_name); |
169 | my $req = HTTP::Request->new( GET => $url); |
170 | |
171 | msg( loc("Fetching: '%1'", $url), $verbose ); |
172 | |
173 | my $res = $ua->request( $req ); |
174 | |
175 | unless( $res->is_success ) { |
176 | error( loc( "Fetching report for '%1' failed: %2", |
177 | $url, $res->message ) ); |
178 | return; |
179 | } |
180 | |
181 | my $aref = YAML::Load( $res->content ); |
182 | |
183 | my $dist = $mod->package_name .'-'. $mod->package_version; |
184 | |
185 | my @rv; |
186 | for my $href ( @$aref ) { |
187 | next unless $all or defined $href->{'distversion'} && |
188 | $href->{'distversion'} eq $dist; |
189 | |
190 | 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 | return @rv if @rv; |
200 | 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 | my $self = shift; |
272 | my $conf = $self->configure_object; |
273 | my %hash = @_; |
274 | |
275 | ### do you even /have/ test::reporter? ### |
276 | unless( $self->_have_send_report_modules(verbose => 1) ) { |
277 | 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 | return; |
281 | } |
282 | |
283 | ### check arguments ### |
284 | my ($buffer, $failed, $mod, $verbose, $force, $address, $save, $dontcc, |
285 | $tests_skipped ); |
286 | 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 | check( $tmpl, \%hash ) or return; |
302 | |
303 | ### get the data to fill the email with ### |
304 | my $name = $mod->module; |
305 | my $dist = $mod->package_name . '-' . $mod->package_version; |
306 | my $author = $mod->author->author; |
307 | my $email = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author ); |
308 | my $cp_conf = $conf->get_conf('cpantest') || ''; |
309 | my $int_ver = $CPANPLUS::Internals::VERSION; |
310 | my $cb = $mod->parent; |
311 | |
312 | |
313 | ### determine the grade now ### |
314 | |
315 | my $grade; |
316 | ### check if this is a platform specific module ### |
317 | ### if we failed the test, there may be reasons why |
318 | ### an 'NA' might have to be insted |
319 | GRADE: { if ( $failed ) { |
320 | |
321 | |
322 | ### XXX duplicated logic between this block |
323 | ### and REPORTED_LOADED_PREREQS :( |
324 | |
325 | ### figure out if the prereqs are on CPAN at all |
326 | ### -- if not, send NA grade |
327 | ### Also, if our version of prereqs is too low, |
328 | ### -- send NA grade. |
329 | ### This is to address bug: #25327: do not count |
330 | ### as FAIL modules where prereqs are not filled |
331 | { my $prq = $mod->status->prereqs || {}; |
332 | |
333 | while( my($prq_name,$prq_ver) = each %$prq ) { |
334 | my $obj = $cb->module_tree( $prq_name ); |
335 | |
336 | unless( $obj ) { |
337 | msg(loc( "Prerequisite '%1' for '%2' could not be obtained". |
338 | " from CPAN -- sending N/A grade", |
339 | $prq_name, $name ), $verbose ); |
340 | |
341 | $grade = GRADE_NA; |
342 | last GRADE; |
343 | } |
344 | |
345 | if( $cb->_vcmp( $prq_ver, $obj->installed_version ) > 0 ) { |
346 | msg(loc( "Installed version of '%1' ('%2') is too low for ". |
347 | "'%3' (needs '%4') -- sending N/A grade", |
348 | $prq_name, $obj->installed_version, |
349 | $name, $prq_ver ), $verbose ); |
350 | |
351 | $grade = GRADE_NA; |
352 | last GRADE; |
353 | } |
354 | } |
355 | } |
356 | |
357 | unless( RELEVANT_TEST_RESULT->($mod) ) { |
358 | msg(loc( |
359 | "'%1' is a platform specific module, and the test results on". |
360 | " your platform are not relevant --sending N/A grade.", |
361 | $name), $verbose); |
362 | |
363 | $grade = GRADE_NA; |
364 | |
365 | } elsif ( UNSUPPORTED_OS->( $buffer ) ) { |
366 | msg(loc( |
367 | "'%1' is a platform specific module, and the test results on". |
368 | " your platform are not relevant --sending N/A grade.", |
369 | $name), $verbose); |
370 | |
371 | $grade = GRADE_NA; |
372 | |
373 | ### you dont have a high enough perl version? |
374 | } elsif ( PERL_VERSION_TOO_LOW->( $buffer ) ) { |
375 | msg(loc("'%1' requires a higher version of perl than your current ". |
376 | "version -- sending N/A grade.", $name), $verbose); |
377 | |
378 | $grade = GRADE_NA; |
379 | |
380 | ### perhaps where were no tests... |
381 | ### see if the thing even had tests ### |
382 | } elsif ( NO_TESTS_DEFINED->( $buffer ) ) { |
383 | $grade = GRADE_UNKNOWN; |
384 | |
385 | } else { |
386 | |
387 | $grade = GRADE_FAIL; |
388 | } |
389 | |
390 | ### if we got here, it didn't fail and tests were present.. so a PASS |
391 | ### is in order |
392 | } else { |
393 | $grade = GRADE_PASS; |
394 | } } |
395 | |
396 | ### so an error occurred, let's see what stage it went wrong in ### |
397 | my $message; |
398 | if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) { |
399 | |
400 | ### return if one or more missing external libraries |
401 | if( my @missing = MISSING_EXTLIBS_LIST->($buffer) ) { |
402 | msg(loc("Not sending test report - " . |
403 | "external libraries not pre-installed")); |
404 | return 1; |
405 | } |
406 | |
407 | ### will be 'fetch', 'make', 'test', 'install', etc ### |
408 | my $stage = TEST_FAIL_STAGE->($buffer); |
409 | |
410 | ### return if we're only supposed to report make_test failures ### |
411 | return 1 if $cp_conf =~ /\bmaketest_only\b/i |
412 | and ($stage !~ /\btest\b/); |
413 | |
414 | ### the header |
415 | $message = REPORT_MESSAGE_HEADER->( $int_ver, $author ); |
416 | |
417 | ### the bit where we inform what went wrong |
418 | $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer ); |
419 | |
420 | ### was it missing prereqs? ### |
421 | if( my @missing = MISSING_PREREQS_LIST->($buffer) ) { |
422 | if(!$self->_verify_missing_prereqs( |
423 | module => $mod, |
424 | missing => \@missing |
425 | )) { |
426 | msg(loc("Not sending test report - " . |
427 | "bogus missing prerequisites report")); |
428 | return 1; |
429 | } |
430 | $message .= REPORT_MISSING_PREREQS->($author,$email,@missing); |
431 | } |
432 | |
433 | ### was it missing test files? ### |
434 | if( NO_TESTS_DEFINED->($buffer) ) { |
435 | $message .= REPORT_MISSING_TESTS->(); |
436 | } |
437 | |
438 | ### add a list of what modules have been loaded of your prereqs list |
439 | $message .= REPORT_LOADED_PREREQS->($mod); |
440 | |
441 | ### the footer |
442 | $message .= REPORT_MESSAGE_FOOTER->(); |
443 | |
444 | ### it may be another grade than fail/unknown.. may be worth noting |
445 | ### that tests got skipped, since the buffer is not added in |
446 | } elsif ( $tests_skipped ) { |
447 | $message .= REPORT_TESTS_SKIPPED->(); |
448 | } |
449 | |
450 | ### if it failed, and that already got reported, we're not cc'ing the |
451 | ### author. Also, 'dont_cc' might be in the config, so check this; |
452 | my $dont_cc_author = $dontcc; |
453 | |
454 | unless( $dont_cc_author ) { |
455 | if( $cp_conf =~ /\bdont_cc\b/i ) { |
456 | $dont_cc_author++; |
457 | |
458 | } elsif ( $grade eq GRADE_PASS ) { |
459 | $dont_cc_author++ |
460 | |
461 | } elsif( $grade eq GRADE_FAIL ) { |
462 | my @already_sent = |
463 | $self->_query_report( module => $mod, verbose => $verbose ); |
464 | |
465 | ### if we can't fetch it, we'll just assume no one |
466 | ### mailed him yet |
467 | my $count = 0; |
468 | if( @already_sent ) { |
469 | for my $href (@already_sent) { |
470 | $count++ if uc $href->{'grade'} eq uc GRADE_FAIL; |
471 | } |
472 | } |
473 | |
474 | if( $count > MAX_REPORT_SEND and !$force) { |
475 | msg(loc("'%1' already reported for '%2', ". |
476 | "not cc-ing the author", |
477 | GRADE_FAIL, $dist ), $verbose ); |
478 | $dont_cc_author++; |
479 | } |
480 | } |
481 | } |
482 | |
483 | ### reporter object ### |
484 | my $reporter = Test::Reporter->new( |
485 | grade => $grade, |
486 | distribution => $dist, |
487 | via => "CPANPLUS $int_ver", |
488 | debug => $conf->get_conf('debug'), |
489 | ); |
490 | |
491 | ### set a custom mx, if requested |
492 | $reporter->mx( [ $conf->get_conf('cpantest_mx') ] ) |
493 | if $conf->get_conf('cpantest_mx'); |
494 | |
495 | ### set the from address ### |
496 | $reporter->from( $conf->get_conf('email') ) |
497 | if $conf->get_conf('email') !~ /\@example\.\w+$/i; |
498 | |
499 | ### give the user a chance to programattically alter the message |
500 | $message = $self->_callbacks->munge_test_report->($mod, $message, $grade); |
501 | |
502 | ### add the body if we have any ### |
503 | $reporter->comments( $message ) if defined $message && length $message; |
504 | |
505 | ### do a callback to ask if we should send the report |
506 | unless ($self->_callbacks->send_test_report->($mod, $grade)) { |
507 | msg(loc("Ok, not sending test report")); |
508 | return 1; |
509 | } |
510 | |
511 | ### do a callback to ask if we should edit the report |
512 | if ($self->_callbacks->edit_test_report->($mod, $grade)) { |
513 | ### test::reporter 1.20 and lower don't have a way to set |
514 | ### the preferred editor with a method call, but it does |
515 | ### respect your env variable, so let's set that. |
516 | local $ENV{VISUAL} = $conf->get_program('editor') |
517 | if $conf->get_program('editor'); |
518 | |
519 | $reporter->edit_comments; |
520 | } |
521 | |
522 | ### people to mail ### |
523 | my @inform; |
524 | #push @inform, $email unless $dont_cc_author; |
525 | |
526 | ### allow to be overridden, but default to the normal address ### |
527 | $reporter->address( $address ); |
528 | |
529 | ### should we save it locally? ### |
530 | if( $save ) { |
531 | if( my $file = $reporter->write() ) { |
532 | msg(loc("Successfully wrote report for '%1' to '%2'", |
533 | $dist, $file), $verbose); |
534 | return $file; |
535 | |
536 | } else { |
537 | error(loc("Failed to write report for '%1'", $dist)); |
538 | return; |
539 | } |
540 | |
541 | ### should we send it to a bunch of people? ### |
542 | ### XXX should we do an 'already sent' check? ### |
543 | } elsif( $reporter->send( @inform ) ) { |
544 | msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist), |
545 | $verbose); |
546 | return 1; |
547 | |
548 | ### something broke :( ### |
549 | } else { |
550 | error(loc("Could not send '%1' report for '%2': %3", |
551 | $grade, $dist, $reporter->errstr)); |
552 | return; |
553 | } |
554 | } |
555 | |
556 | sub _verify_missing_prereqs { |
557 | my $self = shift; |
558 | my %hash = @_; |
559 | |
560 | ### check arguments ### |
561 | my ($mod, $missing); |
562 | my $tmpl = { |
563 | module => { required => 1, store => \$mod }, |
564 | missing => { required => 1, store => \$missing }, |
565 | }; |
566 | |
567 | check( $tmpl, \%hash ) or return; |
568 | |
569 | |
570 | my %missing = map {$_ => 1} @$missing; |
571 | my $conf = $self->configure_object; |
572 | my $extract = $mod->status->extract; |
573 | |
574 | ### Read pre-requisites from Makefile.PL or Build.PL (if there is one), |
575 | ### of the form: |
576 | ### 'PREREQ_PM' => { |
577 | ### 'Compress::Zlib' => '1.20', |
578 | ### 'Test::More' => 0, |
579 | ### }, |
580 | ### Build.PL uses 'requires' instead of 'PREREQ_PM'. |
581 | |
582 | my @search; |
583 | push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->()); |
584 | push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->()); |
585 | |
586 | for my $file ( @search ) { |
587 | if(-e $file and -r $file) { |
588 | my $slurp = $self->_get_file_contents(file => $file); |
589 | my ($prereq) = |
590 | ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s); |
591 | my @prereq = |
592 | ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg); |
593 | delete $missing{$_} for(@prereq); |
594 | } |
595 | } |
596 | |
597 | return 1 if(keys %missing); # There ARE missing prerequisites |
598 | return; # All prerequisites accounted for |
599 | } |
600 | |
601 | 1; |
602 | |
603 | |
604 | # Local variables: |
605 | # c-indentation-style: bsd |
606 | # c-basic-offset: 4 |
607 | # indent-tabs-mode: nil |
608 | # End: |
609 | # vim: expandtab shiftwidth=4: |