1 package CPANPLUS::Internals::Report;
6 use CPANPLUS::Internals::Constants;
7 use CPANPLUS::Internals::Constants::Report;
11 use Params::Check qw[check];
12 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
13 use Module::Load::Conditional qw[can_load];
15 $Params::Check::VERBOSE = 1;
17 ### for the version ###
18 require CPANPLUS::Internals;
22 CPANPLUS::Internals::Report
26 ### enable test reporting
27 $cb->configure_object->set_conf( cpantest => 1 );
29 ### set custom mx host, shouldn't normally be needed
30 $cb->configure_object->set_conf( cpantest_mx => 'smtp.example.com' );
34 This module provides all the functionality to send test reports to
35 C<http://testers.cpan.org> using the C<Test::Reporter> module.
37 All methods will be called automatically if you have C<CPANPLUS>
38 configured to enable test reporting (see the C<SYNOPSIS>).
42 =head2 $bool = $cb->_have_query_report_modules
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
48 =head2 $bool = $cb->_have_send_report_modules
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
57 'LWP::UserAgent' => '0.0',
58 'HTTP::Request' => '0.0',
65 'Test::Reporter' => 1.27,
68 sub _have_query_report_modules {
70 my $conf = $self->configure_object;
74 verbose => { default => $conf->get_conf('verbose') },
77 my $args = check( $tmpl, \%hash ) or return;
79 return can_load( modules => $query_list, verbose => $args->{verbose} )
84 sub _have_send_report_modules {
86 my $conf = $self->configure_object;
90 verbose => { default => $conf->get_conf('verbose') },
93 my $args = check( $tmpl, \%hash ) or return;
95 return can_load( modules => $send_list, verbose => $args->{verbose} )
101 =head2 @list = $cb->_query_report( module => $modobj, [all_versions => BOOL, verbose => BOOL] )
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.
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).
111 Returns the a list with the following data structures (for CPANPLUS
112 version 0.042) on success, or false on failure:
116 'dist' => 'CPANPLUS-0.042',
117 'platform' => 'i686-pld-linux-thread-multi'
121 'dist' => 'CPANPLUS-0.042',
122 'platform' => 'i686-linux-thread-multi'
126 'dist' => 'CPANPLUS-0.042',
127 'platform' => 'cygwin-multi-64int',
128 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371'
132 'dist' => 'CPANPLUS-0.042',
133 'platform' => 'i586-linux',
134 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396'
137 The status of the test can be one of the following:
138 UNKNOWN, PASS, FAIL or NA (not applicable).
144 my $conf = $self->configure_object;
147 my($mod, $verbose, $all);
149 module => { required => 1, allow => IS_MODOBJ,
151 verbose => { default => $conf->get_conf('verbose'),
152 store => \$verbose },
153 all_versions => { default => 0, store => \$all },
156 check( $tmpl, \%hash ) or return;
158 ### check if we have the modules we need for querying
159 return unless $self->_have_query_report_modules( verbose => 1 );
161 ### new user agent ###
162 my $ua = LWP::UserAgent->new;
163 $ua->agent( CPANPLUS_UA->() );
165 ### set proxies if we have them ###
168 my $url = TESTERS_URL->($mod->package_name);
169 my $req = HTTP::Request->new( GET => $url);
171 msg( loc("Fetching: '%1'", $url), $verbose );
173 my $res = $ua->request( $req );
175 unless( $res->is_success ) {
176 error( loc( "Fetching report for '%1' failed: %2",
177 $url, $res->message ) );
181 my $aref = YAML::Load( $res->content );
183 my $dist = $mod->package_name .'-'. $mod->package_version;
186 for my $href ( @$aref ) {
187 next unless $all or defined $href->{'distversion'} &&
188 $href->{'distversion'} eq $dist;
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))
205 =head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, dontcc => BOOL, verbose => BOOL, force => BOOL]);
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.
211 It takes the following options:
217 The module object of this particular distribution
221 The output buffer from the 'make/make test' process
225 Boolean indicating if the 'make/make test' went wrong
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'.
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.
240 Defaults to C<cpan-testers@perl.org>.
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.
254 Boolean indicating on whether or not to be verbose.
256 Defaults to your configuration settings
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.
264 Defaults to your configuration settings
272 my $conf = $self->configure_object;
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' ) );
283 ### check arguments ###
284 my ($buffer, $failed, $mod, $verbose, $force, $address, $save, $dontcc,
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'),
298 => { default => 0, store => \$tests_skipped },
301 check( $tmpl, \%hash ) or return;
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;
313 ### determine the grade now ###
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 ) {
322 ### XXX duplicated logic between this block
323 ### and REPORTED_LOADED_PREREQS :(
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 || {};
333 while( my($prq_name,$prq_ver) = each %$prq ) {
334 my $obj = $cb->module_tree( $prq_name );
337 msg(loc( "Prerequisite '%1' for '%2' could not be obtained".
338 " from CPAN -- sending N/A grade",
339 $prq_name, $name ), $verbose );
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 );
357 unless( RELEVANT_TEST_RESULT->($mod) ) {
359 "'%1' is a platform specific module, and the test results on".
360 " your platform are not relevant --sending N/A grade.",
365 } elsif ( UNSUPPORTED_OS->( $buffer ) ) {
367 "'%1' is a platform specific module, and the test results on".
368 " your platform are not relevant --sending N/A grade.",
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);
380 ### perhaps where were no tests...
381 ### see if the thing even had tests ###
382 } elsif ( NO_TESTS_DEFINED->( $buffer ) ) {
383 $grade = GRADE_UNKNOWN;
390 ### if we got here, it didn't fail and tests were present.. so a PASS
396 ### so an error occurred, let's see what stage it went wrong in ###
398 if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) {
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"));
407 ### will be 'fetch', 'make', 'test', 'install', etc ###
408 my $stage = TEST_FAIL_STAGE->($buffer);
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/);
415 $message = REPORT_MESSAGE_HEADER->( $int_ver, $author );
417 ### the bit where we inform what went wrong
418 $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );
420 ### was it missing prereqs? ###
421 if( my @missing = MISSING_PREREQS_LIST->($buffer) ) {
422 if(!$self->_verify_missing_prereqs(
426 msg(loc("Not sending test report - " .
427 "bogus missing prerequisites report"));
430 $message .= REPORT_MISSING_PREREQS->($author,$email,@missing);
433 ### was it missing test files? ###
434 if( NO_TESTS_DEFINED->($buffer) ) {
435 $message .= REPORT_MISSING_TESTS->();
438 ### add a list of what modules have been loaded of your prereqs list
439 $message .= REPORT_LOADED_PREREQS->($mod);
442 $message .= REPORT_MESSAGE_FOOTER->();
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->();
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;
454 unless( $dont_cc_author ) {
455 if( $cp_conf =~ /\bdont_cc\b/i ) {
458 } elsif ( $grade eq GRADE_PASS ) {
461 } elsif( $grade eq GRADE_FAIL ) {
463 $self->_query_report( module => $mod, verbose => $verbose );
465 ### if we can't fetch it, we'll just assume no one
468 if( @already_sent ) {
469 for my $href (@already_sent) {
470 $count++ if uc $href->{'grade'} eq uc GRADE_FAIL;
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 );
483 ### reporter object ###
484 my $reporter = Test::Reporter->new(
486 distribution => $dist,
487 via => "CPANPLUS $int_ver",
488 debug => $conf->get_conf('debug'),
491 ### set a custom mx, if requested
492 $reporter->mx( [ $conf->get_conf('cpantest_mx') ] )
493 if $conf->get_conf('cpantest_mx');
495 ### set the from address ###
496 $reporter->from( $conf->get_conf('email') )
497 if $conf->get_conf('email') !~ /\@example\.\w+$/i;
499 ### give the user a chance to programattically alter the message
500 $message = $self->_callbacks->munge_test_report->($mod, $message, $grade);
502 ### add the body if we have any ###
503 $reporter->comments( $message ) if defined $message && length $message;
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"));
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');
519 $reporter->edit_comments;
522 ### people to mail ###
524 #push @inform, $email unless $dont_cc_author;
526 ### allow to be overridden, but default to the normal address ###
527 $reporter->address( $address );
529 ### should we save it locally? ###
531 if( my $file = $reporter->write() ) {
532 msg(loc("Successfully wrote report for '%1' to '%2'",
533 $dist, $file), $verbose);
537 error(loc("Failed to write report for '%1'", $dist));
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),
548 ### something broke :( ###
550 error(loc("Could not send '%1' report for '%2': %3",
551 $grade, $dist, $reporter->errstr));
556 sub _verify_missing_prereqs {
560 ### check arguments ###
563 module => { required => 1, store => \$mod },
564 missing => { required => 1, store => \$missing },
567 check( $tmpl, \%hash ) or return;
570 my %missing = map {$_ => 1} @$missing;
571 my $conf = $self->configure_object;
572 my $extract = $mod->status->extract;
574 ### Read pre-requisites from Makefile.PL or Build.PL (if there is one),
577 ### 'Compress::Zlib' => '1.20',
578 ### 'Test::More' => 0,
580 ### Build.PL uses 'requires' instead of 'PREREQ_PM'.
583 push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->());
584 push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->());
586 for my $file ( @search ) {
587 if(-e $file and -r $file) {
588 my $slurp = $self->_get_file_contents(file => $file);
590 ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s);
592 ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg);
593 delete $missing{$_} for(@prereq);
597 return 1 if(keys %missing); # There ARE missing prerequisites
598 return; # All prerequisites accounted for
605 # c-indentation-style: bsd
607 # indent-tabs-mode: nil
609 # vim: expandtab shiftwidth=4: