ext/CPANPLUS/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. The contents of the
 114 data structure depends on what I<http://testers.cpan.org> returns,
 115 but generally looks like this:
 116
 117           {
 118             'grade' => 'PASS',
 119             'dist' => 'CPANPLUS-0.042',
 120             'platform' => 'i686-pld-linux-thread-multi'
 121             'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/98316'
 122             ...
 123           },
 124           {
 125             'grade' => 'PASS',
 126             'dist' => 'CPANPLUS-0.042',
 127             'platform' => 'i686-linux-thread-multi'
 128             'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99416'
 129             ...
 130           },
 131           {
 132             'grade' => 'FAIL',
 133             'dist' => 'CPANPLUS-0.042',
 134             'platform' => 'cygwin-multi-64int',
 135             'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371'
 136             ...
 137           },
 138           {
 139             'grade' => 'FAIL',
 140             'dist' => 'CPANPLUS-0.042',
 141             'platform' => 'i586-linux',
 142             'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396'
 143             ...
 144           },
 145
 146 The status of the test can be one of the following:
 147 UNKNOWN, PASS, FAIL or NA (not applicable).
 148
 149 =cut
 150
 151 sub _query_report {
 152     my $self = shift;
 153     my $conf = $self->configure_object;
 154     my %hash = @_;
 155
 156     my($mod, $verbose, $all);
 157     my $tmpl = {
 158         module          => { required => 1, allow => IS_MODOBJ,
 159                                 store => \$mod },
 160         verbose         => { default => $conf->get_conf('verbose'),
 161                                 store => \$verbose },
 162         all_versions    => { default => 0, store => \$all },
 163     };
 164
 165     check( $tmpl, \%hash ) or return;
 166
 167     ### check if we have the modules we need for querying
 168     return unless $self->_have_query_report_modules( verbose => 1 );
 169
 170
 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->() );
 175     #
 176     ### set proxies if we have them ###
 177     # $ua->env_proxy();
 178
 179     my $url = TESTERS_URL->($mod->package_name);
 180     my $ff  = File::Fetch->new( uri => $url );
 181
 182     msg( loc("Fetching: '%1'", $url), $verbose );
 183
 184     my $res = do {
 185         my $tempdir = File::Temp::tempdir();
 186         my $where   = $ff->fetch( to => $tempdir );
 187
 188         unless( $where ) {
 189             error( loc( "Fetching report for '%1' failed: %2",
 190                         $url, $ff->error ) );
 191             return;
 192         }
 193
 194         my $fh = OPEN_FILE->( $where );
 195
 196         do { local $/; <$fh> };
 197     };
 198
 199     my ($aref) = eval { YAML::Tiny::Load( $res ) };
 200
 201     if( $@ ) {
 202         error(loc("Error reading result: %1", $@));
 203         return;
 204     };
 205
 206     my $dist    = $mod->package_name .'-'. $mod->package_version;
 207     my $details = TESTERS_DETAILS_URL->($mod->package_name);
 208
 209     my @rv;
 210     for my $href ( @$aref ) {
 211         next unless $all or defined $href->{'distversion'} &&
 212                             $href->{'distversion'} eq $dist;
 213
 214         $href->{'details'}  = $details;
 215
 216         ### backwards compatibility :(
 217         $href->{'dist'}     ||= $href->{'distversion'};
 218         $href->{'grade'}    ||= $href->{'action'} || $href->{'status'};
 219
 220         push @rv, $href;
 221     }
 222
 223     return @rv if @rv;
 224     return;
 225 }
 226
 227 =pod
 228
 229 =head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, verbose => BOOL, force => BOOL]);
 230
 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.
 234
 235 It takes the following options:
 236
 237 =over 4
 238
 239 =item module
 240
 241 The module object of this particular distribution
 242
 243 =item buffer
 244
 245 The output buffer from the 'make/make test' process
 246
 247 =item failed
 248
 249 Boolean indicating if the 'make/make test' went wrong
 250
 251 =item save
 252
 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'.
 256
 257 Defaults to false.
 258
 259 =item address
 260
 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.
 263
 264 Defaults to C<cpan-testers@perl.org>.
 265
 266 =item verbose
 267
 268 Boolean indicating on whether or not to be verbose.
 269
 270 Defaults to your configuration settings
 271
 272 =item force
 273
 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.
 277
 278 Defaults to your configuration settings
 279
 280 =back
 281
 282 =cut
 283
 284 sub _send_report {
 285     my $self = shift;
 286     my $conf = $self->configure_object;
 287     my %hash = @_;
 288
 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' ) );
 294         return;
 295     }
 296
 297     ### check arguments ###
 298     my ($buffer, $failed, $mod, $verbose, $force, $address, $save,
 299         $tests_skipped );
 300     my $tmpl = {
 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'),
 309                             store => \$force },
 310             tests_skipped
 311                     => { default => 0, store => \$tests_skipped },
 312     };
 313
 314     check( $tmpl, \%hash ) or return;
 315
 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;
 324
 325
 326     ### will be 'fetch', 'make', 'test', 'install', etc ###
 327     my $stage   = TEST_FAIL_STAGE->($buffer);
 328
 329     ### determine the grade now ###
 330
 331     my $grade;
 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 ) {
 336
 337
 338         ### XXX duplicated logic between this block
 339         ### and REPORTED_LOADED_PREREQS :(
 340
 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 || {};
 348
 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' );
 353
 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 );
 365
 366                     $grade = GRADE_NA;
 367                     last GRADE;
 368                 }
 369
 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 );
 375
 376                     $grade = GRADE_NA;
 377                     last GRADE;
 378                 }
 379             }
 380         }
 381
 382         unless( RELEVANT_TEST_RESULT->($mod) ) {
 383             msg(loc(
 384                 "'%1' is a platform specific module, and the test results on".
 385                 " your platform are not relevant --sending N/A grade.",
 386                 $name), $verbose);
 387
 388             $grade = GRADE_NA;
 389
 390         } elsif ( UNSUPPORTED_OS->( $buffer ) ) {
 391             msg(loc(
 392                 "'%1' is a platform specific module, and the test results on".
 393                 " your platform are not relevant --sending N/A grade.",
 394                 $name), $verbose);
 395
 396             $grade = GRADE_NA;
 397
 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);
 402
 403             $grade = GRADE_NA;
 404
 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/ ) {
 411
 412             $grade = GRADE_UNKNOWN
 413
 414         } else {
 415
 416             $grade = GRADE_FAIL;
 417         }
 418
 419     ### if we got here, it didn't fail and tests were present.. so a PASS
 420     ### is in order
 421     } else {
 422         $grade = GRADE_PASS;
 423     } }
 424
 425     ### so an error occurred, let's see what stage it went wrong in ###
 426
 427     ### the header -- always include so the CPANPLUS version is apparent
 428     my $message =  REPORT_MESSAGE_HEADER->( $int_ver, $author );
 429
 430     if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) {
 431
 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"));
 436             return 1;
 437         }
 438
 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/);
 442
 443         ### the bit where we inform what went wrong
 444         $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );
 445
 446         ### was it missing prereqs? ###
 447         if( my @missing = MISSING_PREREQS_LIST->($buffer) ) {
 448             if(!$self->_verify_missing_prereqs(
 449                                 module  => $mod,
 450                                 missing => \@missing
 451                         )) {
 452                 msg(loc("Not sending test report - "  .
 453                         "bogus missing prerequisites report"));
 454                 return 1;
 455             }
 456             $message .= REPORT_MISSING_PREREQS->($author,$email,@missing);
 457         }
 458
 459         ### was it missing test files? ###
 460         if( NO_TESTS_DEFINED->($buffer) ) {
 461             $message .= REPORT_MISSING_TESTS->();
 462         }
 463
 464         ### add a list of what modules have been loaded of your prereqs list
 465         $message .= REPORT_LOADED_PREREQS->($mod);
 466
 467         ### the footer
 468         $message .= REPORT_MESSAGE_FOOTER->();
 469
 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) {
 475
 476         ### the bit where we inform what went wrong
 477         $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );
 478
 479         ### the footer
 480         $message .= REPORT_MESSAGE_FOOTER->();
 481
 482     }
 483
 484     msg( loc("Sending test report for '%1'", $dist), $verbose);
 485
 486     ### reporter object ###
 487     my $reporter = do {
 488         my $args = $conf->get_conf('cpantest_reporter_args') || {};
 489
 490         unless( UNIVERSAL::isa( $args, 'HASH' ) ) {
 491             error(loc("'%1' must be a hashref, ignoring...",
 492                       'cpantest_reporter_args'));
 493             $args = {};
 494         }
 495
 496         Test::Reporter->new(
 497             grade           => $grade,
 498             distribution    => $dist,
 499             via             => "CPANPLUS $int_ver",
 500             timeout         => $conf->get_conf('timeout') || 60,
 501             debug           => $conf->get_conf('debug'),
 502             %$args,
 503         );
 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     ### allow to be overridden, but default to the normal address ###
 538     $reporter->address( $address );
 539
 540     ### should we save it locally? ###
 541     if( $save ) {
 542         if( my $file = $reporter->write() ) {
 543             msg(loc("Successfully wrote report for '%1' to '%2'",
 544                     $dist, $file), $verbose);
 545             return $file;
 546
 547         } else {
 548             error(loc("Failed to write report for '%1'", $dist));
 549             return;
 550         }
 551
 552     ### XXX should we do an 'already sent' check? ###
 553     } elsif( $reporter->send( ) ) {
 554         msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist),
 555             $verbose);
 556         return 1;
 557
 558     ### something broke :( ###
 559     } else {
 560         error(loc("Could not send '%1' report for '%2': %3",
 561                 $grade, $dist, $reporter->errstr));
 562         return;
 563     }
 564 }
 565
 566 sub _verify_missing_prereqs {
 567     my $self = shift;
 568     my %hash = @_;
 569
 570     ### check arguments ###
 571     my ($mod, $missing);
 572     my $tmpl = {
 573             module  => { required => 1, store => \$mod },
 574             missing => { required => 1, store => \$missing },
 575     };
 576
 577     check( $tmpl, \%hash ) or return;
 578
 579
 580     my %missing = map {$_ => 1} @$missing;
 581     my $conf = $self->configure_object;
 582     my $extract = $mod->status->extract;
 583
 584     ### Read pre-requisites from Makefile.PL or Build.PL (if there is one),
 585     ### of the form:
 586     ###     'PREREQ_PM' => {
 587     ###                      'Compress::Zlib'        => '1.20',
 588     ###                      'Test::More'            => 0,
 589     ###                    },
 590     ###  Build.PL uses 'requires' instead of 'PREREQ_PM'.
 591
 592     my @search;
 593     push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->());
 594     push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->());
 595
 596     for my $file ( @search ) {
 597         if(-e $file and -r $file) {
 598             my $slurp = $self->_get_file_contents(file => $file);
 599             my ($prereq) =
 600                 ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s);
 601             my @prereq =
 602                 ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg);
 603             delete $missing{$_} for(@prereq);
 604         }
 605     }
 606
 607     return 1    if(keys %missing);  # There ARE missing prerequisites
 608     return;                         # All prerequisites accounted for
 609 }
 610
 611 1;
 612
 613
 614 # Local variables:
 615 # c-indentation-style: bsd
 616 # c-basic-offset: 4
 617 # indent-tabs-mode: nil
 618 # End:
 619 # vim: expandtab shiftwidth=4: