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