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