[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/5.10.0/CPANPLUS/Internals/ -> Report.pm (source)

   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:


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1