[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
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:
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |