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 Module::Load::Conditional   qw[can_load];
  13 use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';
  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         'File::Fetch'   => '0.08',
  57         'YAML::Tiny'    => '0.0',
  58         'File::Temp'    => '0.0',
  59     };
  60
  61     my $send_list = {
  62         %$query_list,
  63         'Test::Reporter' => '1.34',
  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
 159
 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     #
 165     ### set proxies if we have them ###
 166     # $ua->env_proxy();
 167
 168     my $url = TESTERS_URL->($mod->package_name);
 169     my $ff  = File::Fetch->new( uri => $url );
 170
 171     msg( loc("Fetching: '%1'", $url), $verbose );
 172
 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         }
 182
 183         my $fh = OPEN_FILE->( $where );
 184
 185         do { local $/; <$fh> };
 186     };
 187
 188     my ($aref) = eval { YAML::Tiny::Load( $res ) };
 189
 190     if( $@ ) {
 191         error(loc("Error reading result: %1", $@));
 192         return;
 193     };
 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
 454         $message .= REPORT_MESSAGE_FOOTER->();
 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     }
 494
 495     msg( loc("Sending test report for '%1'", $dist), $verbose);
 496
 497     ### reporter object ###
 498     my $reporter = Test::Reporter->new(
 499                         grade           => $grade,
 500                         distribution    => $dist,
 501                         via             => "CPANPLUS $int_ver",
 502                         timeout         => $conf->get_conf('timeout') || 60,
 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: