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
  56 ### XXX remove this list and move it into selfupdate, somehow..
  57 ### this is dual administration
  58 {   my $query_list = {
  59         'File::Fetch'   => '0.13_02',
  60         'YAML::Tiny'    => '0.0',
  61         'File::Temp'    => '0.0',
  62     };
  63
  64     my $send_list = {
  65         %$query_list,
  66         'Test::Reporter' => '1.34',
  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
 162
 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     #
 168     ### set proxies if we have them ###
 169     # $ua->env_proxy();
 170
 171     my $url = TESTERS_URL->($mod->package_name);
 172     my $ff  = File::Fetch->new( uri => $url );
 173
 174     msg( loc("Fetching: '%1'", $url), $verbose );
 175
 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         }
 185
 186         my $fh = OPEN_FILE->( $where );
 187
 188         do { local $/; <$fh> };
 189     };
 190
 191     my ($aref) = eval { YAML::Tiny::Load( $res ) };
 192
 193     if( $@ ) {
 194         error(loc("Error reading result: %1", $@));
 195         return;
 196     };
 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
 457         $message .= REPORT_MESSAGE_FOOTER->();
 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     }
 497
 498     msg( loc("Sending test report for '%1'", $dist), $verbose);
 499
 500     ### reporter object ###
 501     my $reporter = Test::Reporter->new(
 502                         grade           => $grade,
 503                         distribution    => $dist,
 504                         via             => "CPANPLUS $int_ver",
 505                         timeout         => $conf->get_conf('timeout') || 60,
 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: