Update CPANPLUS to 0.87_03
[perl.git] / 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: