lib/CPANPLUS/Internals/Report.pm

   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: