1 package CPANPLUS::Internals::Report;
6 use CPANPLUS::Internals::Constants;
7 use CPANPLUS::Internals::Constants::Report;
11 use Params::Check qw[check];
12 use Module::Load::Conditional qw[can_load];
13 use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
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
56 ### XXX remove this list and move it into selfupdate, somehow..
57 ### this is dual administration
59 'File::Fetch' => '0.13_02',
60 'YAML::Tiny' => '0.0',
61 'File::Temp' => '0.0',
66 'Test::Reporter' => '1.34',
69 sub _have_query_report_modules {
71 my $conf = $self->configure_object;
75 verbose => { default => $conf->get_conf('verbose') },
78 my $args = check( $tmpl, \%hash ) or return;
80 return can_load( modules => $query_list, verbose => $args->{verbose} )
85 sub _have_send_report_modules {
87 my $conf = $self->configure_object;
91 verbose => { default => $conf->get_conf('verbose') },
94 my $args = check( $tmpl, \%hash ) or return;
96 return can_load( modules => $send_list, verbose => $args->{verbose} )
102 =head2 @list = $cb->_query_report( module => $modobj, [all_versions => BOOL, verbose => BOOL] )
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.
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).
112 Returns the a list with the following data structures (for CPANPLUS
113 version 0.042) on success, or false on failure. The contents of the
114 data structure depends on what I<http://testers.cpan.org> returns,
115 but generally looks like this:
119 'dist' => 'CPANPLUS-0.042',
120 'platform' => 'i686-pld-linux-thread-multi'
121 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/98316'
126 'dist' => 'CPANPLUS-0.042',
127 'platform' => 'i686-linux-thread-multi'
128 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99416'
133 'dist' => 'CPANPLUS-0.042',
134 'platform' => 'cygwin-multi-64int',
135 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371'
140 'dist' => 'CPANPLUS-0.042',
141 'platform' => 'i586-linux',
142 'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396'
146 The status of the test can be one of the following:
147 UNKNOWN, PASS, FAIL or NA (not applicable).
153 my $conf = $self->configure_object;
156 my($mod, $verbose, $all);
158 module => { required => 1, allow => IS_MODOBJ,
160 verbose => { default => $conf->get_conf('verbose'),
161 store => \$verbose },
162 all_versions => { default => 0, store => \$all },
165 check( $tmpl, \%hash ) or return;
167 ### check if we have the modules we need for querying
168 return unless $self->_have_query_report_modules( verbose => 1 );
171 ### XXX no longer use LWP here. However, that means we don't
172 ### automagically set proxies anymore!!!
173 # my $ua = LWP::UserAgent->new;
174 # $ua->agent( CPANPLUS_UA->() );
176 ### set proxies if we have them ###
179 my $url = TESTERS_URL->($mod->package_name);
180 my $ff = File::Fetch->new( uri => $url );
182 msg( loc("Fetching: '%1'", $url), $verbose );
185 my $tempdir = File::Temp::tempdir();
186 my $where = $ff->fetch( to => $tempdir );
189 error( loc( "Fetching report for '%1' failed: %2",
190 $url, $ff->error ) );
194 my $fh = OPEN_FILE->( $where );
196 do { local $/; <$fh> };
199 my ($aref) = eval { YAML::Tiny::Load( $res ) };
202 error(loc("Error reading result: %1", $@));
206 my $dist = $mod->package_name .'-'. $mod->package_version;
207 my $details = TESTERS_DETAILS_URL->($mod->package_name);
210 for my $href ( @$aref ) {
211 next unless $all or defined $href->{'distversion'} &&
212 $href->{'distversion'} eq $dist;
214 $href->{'details'} = $details;
216 ### backwards compatibility :(
217 $href->{'dist'} ||= $href->{'distversion'};
218 $href->{'grade'} ||= $href->{'action'} || $href->{'status'};
229 =head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, verbose => BOOL, force => BOOL]);
231 This function sends a testers report to C<cpan-testers@perl.org> for a
232 particular distribution.
233 It returns true on success, and false on failure.
235 It takes the following options:
241 The module object of this particular distribution
245 The output buffer from the 'make/make test' process
249 Boolean indicating if the 'make/make test' went wrong
253 Boolean indicating if the report should be saved locally instead of
254 mailed out. If provided, this function will return the location the
255 report was saved to, rather than a simple boolean 'TRUE'.
261 The email address to mail the report for. You should never need to
262 override this, but it might be useful for debugging purposes.
264 Defaults to C<cpan-testers@perl.org>.
268 Boolean indicating on whether or not to be verbose.
270 Defaults to your configuration settings
274 Boolean indicating whether to force the sending, even if the max
275 amount of reports for fails have already been reached, or if you
276 may already have sent it before.
278 Defaults to your configuration settings
286 my $conf = $self->configure_object;
289 ### do you even /have/ test::reporter? ###
290 unless( $self->_have_send_report_modules(verbose => 1) ) {
291 error( loc( "You don't have '%1' (or modules required by '%2') ".
292 "installed, you cannot report test results.",
293 'Test::Reporter', 'Test::Reporter' ) );
297 ### check arguments ###
298 my ($buffer, $failed, $mod, $verbose, $force, $address, $save,
301 module => { required => 1, store => \$mod, allow => IS_MODOBJ },
302 buffer => { required => 1, store => \$buffer },
303 failed => { required => 1, store => \$failed },
304 address => { default => CPAN_TESTERS_EMAIL, store => \$address },
305 save => { default => 0, store => \$save },
306 verbose => { default => $conf->get_conf('verbose'),
307 store => \$verbose },
308 force => { default => $conf->get_conf('force'),
311 => { default => 0, store => \$tests_skipped },
314 check( $tmpl, \%hash ) or return;
316 ### get the data to fill the email with ###
317 my $name = $mod->module;
318 my $dist = $mod->package_name . '-' . $mod->package_version;
319 my $author = $mod->author->author;
320 my $email = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author );
321 my $cp_conf = $conf->get_conf('cpantest') || '';
322 my $int_ver = $CPANPLUS::Internals::VERSION;
323 my $cb = $mod->parent;
326 ### will be 'fetch', 'make', 'test', 'install', etc ###
327 my $stage = TEST_FAIL_STAGE->($buffer);
329 ### determine the grade now ###
332 ### check if this is a platform specific module ###
333 ### if we failed the test, there may be reasons why
334 ### an 'NA' might have to be insted
335 GRADE: { if ( $failed ) {
338 ### XXX duplicated logic between this block
339 ### and REPORTED_LOADED_PREREQS :(
341 ### figure out if the prereqs are on CPAN at all
342 ### -- if not, send NA grade
343 ### Also, if our version of prereqs is too low,
344 ### -- send NA grade.
345 ### This is to address bug: #25327: do not count
346 ### as FAIL modules where prereqs are not filled
347 { my $prq = $mod->status->prereqs || {};
349 while( my($prq_name,$prq_ver) = each %$prq ) {
350 my $obj = $cb->module_tree( $prq_name );
351 my $sub = CPANPLUS::Module->can(
352 'module_is_supplied_with_perl_core' );
354 ### if we can't find the module and it's not supplied with core.
355 ### this addresses: #32064: NA reports generated for failing
356 ### tests where core prereqs are specified
357 ### Note that due to a bug in Module::CoreList, in some released
358 ### version of perl (5.8.6+ and 5.9.2-4 at the time of writing)
359 ### 'Config' is not recognized as a core module. See this bug:
360 ### http://rt.cpan.org/Ticket/Display.html?id=32155
361 if( not $obj and not $sub->( $prq_name ) ) {
362 msg(loc( "Prerequisite '%1' for '%2' could not be obtained".
363 " from CPAN -- sending N/A grade",
364 $prq_name, $name ), $verbose );
370 if( $cb->_vcmp( $prq_ver, $obj->installed_version ) > 0 ) {
371 msg(loc( "Installed version of '%1' ('%2') is too low for ".
372 "'%3' (needs '%4') -- sending N/A grade",
373 $prq_name, $obj->installed_version,
374 $name, $prq_ver ), $verbose );
382 unless( RELEVANT_TEST_RESULT->($mod) ) {
384 "'%1' is a platform specific module, and the test results on".
385 " your platform are not relevant --sending N/A grade.",
390 } elsif ( UNSUPPORTED_OS->( $buffer ) ) {
392 "'%1' is a platform specific module, and the test results on".
393 " your platform are not relevant --sending N/A grade.",
398 ### you dont have a high enough perl version?
399 } elsif ( PERL_VERSION_TOO_LOW->( $buffer ) ) {
400 msg(loc("'%1' requires a higher version of perl than your current ".
401 "version -- sending N/A grade.", $name), $verbose);
405 ### perhaps where were no tests...
406 ### see if the thing even had tests ###
407 } elsif ( NO_TESTS_DEFINED->( $buffer ) ) {
408 $grade = GRADE_UNKNOWN;
409 ### failures in PL or make/build stage are now considered UNKNOWN
410 } elsif ( $stage !~ /\btest\b/ ) {
412 $grade = GRADE_UNKNOWN
419 ### if we got here, it didn't fail and tests were present.. so a PASS
425 ### so an error occurred, let's see what stage it went wrong in ###
427 ### the header -- always include so the CPANPLUS version is apparent
428 my $message = REPORT_MESSAGE_HEADER->( $int_ver, $author );
430 if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) {
432 ### return if one or more missing external libraries
433 if( my @missing = MISSING_EXTLIBS_LIST->($buffer) ) {
434 msg(loc("Not sending test report - " .
435 "external libraries not pre-installed"));
439 ### return if we're only supposed to report make_test failures ###
440 return 1 if $cp_conf =~ /\bmaketest_only\b/i
441 and ($stage !~ /\btest\b/);
443 ### the bit where we inform what went wrong
444 $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );
446 ### was it missing prereqs? ###
447 if( my @missing = MISSING_PREREQS_LIST->($buffer) ) {
448 if(!$self->_verify_missing_prereqs(
452 msg(loc("Not sending test report - " .
453 "bogus missing prerequisites report"));
456 $message .= REPORT_MISSING_PREREQS->($author,$email,@missing);
459 ### was it missing test files? ###
460 if( NO_TESTS_DEFINED->($buffer) ) {
461 $message .= REPORT_MISSING_TESTS->();
464 ### add a list of what modules have been loaded of your prereqs list
465 $message .= REPORT_LOADED_PREREQS->($mod);
468 $message .= REPORT_MESSAGE_FOOTER->();
470 ### it may be another grade than fail/unknown.. may be worth noting
471 ### that tests got skipped, since the buffer is not added in
472 } elsif ( $tests_skipped ) {
473 $message .= REPORT_TESTS_SKIPPED->();
474 } elsif( $grade eq GRADE_NA) {
476 ### the bit where we inform what went wrong
477 $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );
480 $message .= REPORT_MESSAGE_FOOTER->();
484 msg( loc("Sending test report for '%1'", $dist), $verbose);
486 ### reporter object ###
488 my $args = $conf->get_conf('cpantest_reporter_args') || {};
490 unless( UNIVERSAL::isa( $args, 'HASH' ) ) {
491 error(loc("'%1' must be a hashref, ignoring...",
492 'cpantest_reporter_args'));
498 distribution => $dist,
499 via => "CPANPLUS $int_ver",
500 timeout => $conf->get_conf('timeout') || 60,
501 debug => $conf->get_conf('debug'),
506 ### set a custom mx, if requested
507 $reporter->mx( [ $conf->get_conf('cpantest_mx') ] )
508 if $conf->get_conf('cpantest_mx');
510 ### set the from address ###
511 $reporter->from( $conf->get_conf('email') )
512 if $conf->get_conf('email') !~ /\@example\.\w+$/i;
514 ### give the user a chance to programattically alter the message
515 $message = $self->_callbacks->munge_test_report->($mod, $message, $grade);
517 ### add the body if we have any ###
518 $reporter->comments( $message ) if defined $message && length $message;
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"));
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');
534 $reporter->edit_comments;
537 ### allow to be overridden, but default to the normal address ###
538 $reporter->address( $address );
540 ### should we save it locally? ###
542 if( my $file = $reporter->write() ) {
543 msg(loc("Successfully wrote report for '%1' to '%2'",
544 $dist, $file), $verbose);
548 error(loc("Failed to write report for '%1'", $dist));
552 ### XXX should we do an 'already sent' check? ###
553 } elsif( $reporter->send( ) ) {
554 msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist),
558 ### something broke :( ###
560 error(loc("Could not send '%1' report for '%2': %3",
561 $grade, $dist, $reporter->errstr));
566 sub _verify_missing_prereqs {
570 ### check arguments ###
573 module => { required => 1, store => \$mod },
574 missing => { required => 1, store => \$missing },
577 check( $tmpl, \%hash ) or return;
580 my %missing = map {$_ => 1} @$missing;
581 my $conf = $self->configure_object;
582 my $extract = $mod->status->extract;
584 ### Read pre-requisites from Makefile.PL or Build.PL (if there is one),
587 ### 'Compress::Zlib' => '1.20',
588 ### 'Test::More' => 0,
590 ### Build.PL uses 'requires' instead of 'PREREQ_PM'.
593 push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->());
594 push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->());
596 for my $file ( @search ) {
597 if(-e $file and -r $file) {
598 my $slurp = $self->_get_file_contents(file => $file);
600 ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s);
602 ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg);
603 delete $missing{$_} for(@prereq);
607 return 1 if(keys %missing); # There ARE missing prerequisites
608 return; # All prerequisites accounted for
615 # c-indentation-style: bsd
617 # indent-tabs-mode: nil
619 # vim: expandtab shiftwidth=4: