[p5sagit/p5-mst-13.2.git] / ext / CPANPLUS / lib / CPANPLUS / Internals / Report.pm

package CPANPLUS::Internals::Report;

use strict;

use CPANPLUS::Error;
use CPANPLUS::Internals::Constants;
use CPANPLUS::Internals::Constants::Report;

use Data::Dumper;

use Params::Check               qw[check];
use Module::Load::Conditional   qw[can_load];
use Locale::Maketext::Simple    Class => 'CPANPLUS', Style => 'gettext';

$Params::Check::VERBOSE = 1;

### for the version ###
require CPANPLUS::Internals;

=head1 NAME

CPANPLUS::Internals::Report

=head1 SYNOPSIS

  ### enable test reporting
  $cb->configure_object->set_conf( cpantest => 1 );
    
  ### set custom mx host, shouldn't normally be needed
  $cb->configure_object->set_conf( cpantest_mx => 'smtp.example.com' );

=head1 DESCRIPTION

This module provides all the functionality to send test reports to
C<http://testers.cpan.org> using the C<Test::Reporter> module.

All methods will be called automatically if you have C<CPANPLUS>
configured to enable test reporting (see the C<SYNOPSIS>).

=head1 METHODS

=head2 $bool = $cb->_have_query_report_modules

This function checks if all the required modules are here for querying
reports. It returns true and loads them if they are, or returns false
otherwise.

=head2 $bool = $cb->_have_send_report_modules

This function checks if all the required modules are here for sending
reports. It returns true and loads them if they are, or returns false
otherwise.

=cut

### XXX remove this list and move it into selfupdate, somehow..
### this is dual administration
{   my $query_list = {
        'File::Fetch'   => '0.13_02',
        'YAML::Tiny'    => '0.0',
        'File::Temp'    => '0.0',
    };

    my $send_list = {
        %$query_list,
        'Test::Reporter' => '1.34',
    };

    sub _have_query_report_modules {
        my $self = shift;
        my $conf = $self->configure_object;
        my %hash = @_;

        my $tmpl = {
            verbose => { default => $conf->get_conf('verbose') },
        };

        my $args = check( $tmpl, \%hash ) or return;

        return can_load( modules => $query_list, verbose => $args->{verbose} )
                ? 1
                : 0;
    }

    sub _have_send_report_modules {
        my $self = shift;
        my $conf = $self->configure_object;
        my %hash = @_;

        my $tmpl = {
            verbose => { default => $conf->get_conf('verbose') },
        };

        my $args = check( $tmpl, \%hash ) or return;

        return can_load( modules => $send_list, verbose => $args->{verbose} )
                ? 1
                : 0;
    }
}

=head2 @list = $cb->_query_report( module => $modobj, [all_versions => BOOL, verbose => BOOL] )

This function queries the CPAN testers database at
I<http://testers.cpan.org/> for test results of specified module objects,
module names or distributions. 

The optional argument C<all_versions> controls whether all versions of
a given distribution should be grabbed.  It defaults to false
(fetching only reports for the current version).

Returns the a list with the following data structures (for CPANPLUS
version 0.042) on success, or false on failure. The contents of the
data structure depends on what I<http://testers.cpan.org> returns,
but generally looks like this:

          {
            'grade' => 'PASS',
            'dist' => 'CPANPLUS-0.042',
            'platform' => 'i686-pld-linux-thread-multi'
            'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/98316'
            ...
          },
          {
            'grade' => 'PASS',
            'dist' => 'CPANPLUS-0.042',
            'platform' => 'i686-linux-thread-multi'
            'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99416'
            ...
          },
          {
            'grade' => 'FAIL',
            'dist' => 'CPANPLUS-0.042',
            'platform' => 'cygwin-multi-64int',
            'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99371'
            ...
          },
          {
            'grade' => 'FAIL',
            'dist' => 'CPANPLUS-0.042',
            'platform' => 'i586-linux',
            'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99396'
            ...
          },

The status of the test can be one of the following:
UNKNOWN, PASS, FAIL or NA (not applicable).

=cut

sub _query_report {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;

    my($mod, $verbose, $all);
    my $tmpl = {
        module          => { required => 1, allow => IS_MODOBJ,
                                store => \$mod },
        verbose         => { default => $conf->get_conf('verbose'),
                                store => \$verbose },
        all_versions    => { default => 0, store => \$all },
    };

    check( $tmpl, \%hash ) or return;

    ### check if we have the modules we need for querying
    return unless $self->_have_query_report_modules( verbose => 1 );


    ### XXX no longer use LWP here. However, that means we don't
    ### automagically set proxies anymore!!!
    # my $ua = LWP::UserAgent->new;
    # $ua->agent( CPANPLUS_UA->() );
    #
    ### set proxies if we have them ###
    # $ua->env_proxy();

    my $url = TESTERS_URL->($mod->package_name);
    my $ff  = File::Fetch->new( uri => $url );

    msg( loc("Fetching: '%1'", $url), $verbose );

    my $res = do {
        my $tempdir = File::Temp::tempdir();
        my $where   = $ff->fetch( to => $tempdir );
        
        unless( $where ) {
            error( loc( "Fetching report for '%1' failed: %2",
                        $url, $ff->error ) );
            return;
        }

        my $fh = OPEN_FILE->( $where );
        
        do { local $/; <$fh> };
    };

    my ($aref) = eval { YAML::Tiny::Load( $res ) };

    if( $@ ) {
        error(loc("Error reading result: %1", $@));
        return;
    };

    my $dist    = $mod->package_name .'-'. $mod->package_version;
    my $details = TESTERS_DETAILS_URL->($mod->package_name);

    my @rv;
    for my $href ( @$aref ) {
        next unless $all or defined $href->{'distversion'} && 
                            $href->{'distversion'} eq $dist;

        $href->{'details'}  = $details;
        
        ### backwards compatibility :(
        $href->{'dist'}     ||= $href->{'distversion'};
        $href->{'grade'}    ||= $href->{'action'} || $href->{'status'};

        push @rv, $href;
    }

    return @rv if @rv;
    return;
}

=pod

=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, verbose => BOOL, force => BOOL]);

This function sends a testers report to C<cpan-testers@perl.org> for a
particular distribution.
It returns true on success, and false on failure.

It takes the following options:

=over 4

=item module

The module object of this particular distribution

=item buffer

The output buffer from the 'make/make test' process

=item failed

Boolean indicating if the 'make/make test' went wrong

=item save

Boolean indicating if the report should be saved locally instead of
mailed out. If provided, this function will return the location the
report was saved to, rather than a simple boolean 'TRUE'.

Defaults to false.

=item address

The email address to mail the report for. You should never need to
override this, but it might be useful for debugging purposes.

Defaults to C<cpan-testers@perl.org>.

=item verbose

Boolean indicating on whether or not to be verbose.

Defaults to your configuration settings

=item force

Boolean indicating whether to force the sending, even if the max
amount of reports for fails have already been reached, or if you
may already have sent it before.

Defaults to your configuration settings

=back

=cut

sub _send_report {
    my $self = shift;
    my $conf = $self->configure_object;
    my %hash = @_;

    ### do you even /have/ test::reporter? ###
    unless( $self->_have_send_report_modules(verbose => 1) ) {
        error( loc( "You don't have '%1' (or modules required by '%2') ".
                    "installed, you cannot report test results.",
                    'Test::Reporter', 'Test::Reporter' ) );
        return;
    }

    ### check arguments ###
    my ($buffer, $failed, $mod, $verbose, $force, $address, $save, 
        $tests_skipped );
    my $tmpl = {
            module  => { required => 1, store => \$mod, allow => IS_MODOBJ },
            buffer  => { required => 1, store => \$buffer },
            failed  => { required => 1, store => \$failed },
            address => { default  => CPAN_TESTERS_EMAIL, store => \$address },
            save    => { default  => 0, store => \$save },
            verbose => { default  => $conf->get_conf('verbose'),
                            store => \$verbose },
            force   => { default  => $conf->get_conf('force'),
                            store => \$force },
            tests_skipped   
                    => { default => 0, store => \$tests_skipped },
    };

    check( $tmpl, \%hash ) or return;

    ### get the data to fill the email with ###
    my $name    = $mod->module;
    my $dist    = $mod->package_name . '-' . $mod->package_version;
    my $author  = $mod->author->author;
    my $email   = $mod->author->email || CPAN_MAIL_ACCOUNT->( $author );
    my $cp_conf = $conf->get_conf('cpantest') || '';
    my $int_ver = $CPANPLUS::Internals::VERSION;
    my $cb      = $mod->parent;


    ### will be 'fetch', 'make', 'test', 'install', etc ###
    my $stage   = TEST_FAIL_STAGE->($buffer);

    ### determine the grade now ###

    my $grade;
    ### check if this is a platform specific module ###
    ### if we failed the test, there may be reasons why 
    ### an 'NA' might have to be insted
    GRADE: { if ( $failed ) {
        

        ### XXX duplicated logic between this block
        ### and REPORTED_LOADED_PREREQS :(
        
        ### figure out if the prereqs are on CPAN at all
        ### -- if not, send NA grade
        ### Also, if our version of prereqs is too low,
        ### -- send NA grade.
        ### This is to address bug: #25327: do not count 
        ### as FAIL modules where prereqs are not filled
        {   my $prq = $mod->status->prereqs || {};
        
            while( my($prq_name,$prq_ver) = each %$prq ) {
                my $obj = $cb->module_tree( $prq_name );
                my $sub = CPANPLUS::Module->can(         
                            'module_is_supplied_with_perl_core' );
                
                ### if we can't find the module and it's not supplied with core.
                ### this addresses: #32064: NA reports generated for failing
                ### tests where core prereqs are specified
                ### Note that due to a bug in Module::CoreList, in some released
                ### version of perl (5.8.6+ and 5.9.2-4 at the time of writing)
                ### 'Config' is not recognized as a core module. See this bug:
                ###    http://rt.cpan.org/Ticket/Display.html?id=32155
                if( not $obj and not $sub->( $prq_name ) ) {
                    msg(loc( "Prerequisite '%1' for '%2' could not be obtained".
                             " from CPAN -- sending N/A grade", 
                             $prq_name, $name ), $verbose );

                    $grade = GRADE_NA;
                    last GRADE;        
                }

                if( $cb->_vcmp( $prq_ver, $obj->installed_version ) > 0 ) {
                    msg(loc( "Installed version of '%1' ('%2') is too low for ".
                             "'%3' (needs '%4') -- sending N/A grade", 
                             $prq_name, $obj->installed_version, 
                             $name, $prq_ver ), $verbose );
                             
                    $grade = GRADE_NA;
                    last GRADE;        
                }                             
            }
        }
        
        unless( RELEVANT_TEST_RESULT->($mod) ) {
            msg(loc(
                "'%1' is a platform specific module, and the test results on".
                " your platform are not relevant --sending N/A grade.",
                $name), $verbose);
        
            $grade = GRADE_NA;
        
        } elsif ( UNSUPPORTED_OS->( $buffer ) ) {
            msg(loc(
                "'%1' is a platform specific module, and the test results on".
                " your platform are not relevant --sending N/A grade.",
                $name), $verbose);
        
            $grade = GRADE_NA;
        
        ### you dont have a high enough perl version?    
        } elsif ( PERL_VERSION_TOO_LOW->( $buffer ) ) {
            msg(loc("'%1' requires a higher version of perl than your current ".
                    "version -- sending N/A grade.", $name), $verbose);
        
            $grade = GRADE_NA;                

        ### perhaps where were no tests...
        ### see if the thing even had tests ###
        } elsif ( NO_TESTS_DEFINED->( $buffer ) ) {
            $grade = GRADE_UNKNOWN;
        ### failures in PL or make/build stage are now considered UNKNOWN
        } elsif ( $stage !~ /\btest\b/ ) {

            $grade = GRADE_UNKNOWN

        } else {
            
            $grade = GRADE_FAIL;
        }

    ### if we got here, it didn't fail and tests were present.. so a PASS
    ### is in order
    } else {
        $grade = GRADE_PASS;
    } }

    ### so an error occurred, let's see what stage it went wrong in ###

    ### the header -- always include so the CPANPLUS version is apparent
    my $message =  REPORT_MESSAGE_HEADER->( $int_ver, $author );

    if( $grade eq GRADE_FAIL or $grade eq GRADE_UNKNOWN) {

        ### return if one or more missing external libraries
        if( my @missing = MISSING_EXTLIBS_LIST->($buffer) ) {
            msg(loc("Not sending test report - " .
                    "external libraries not pre-installed"));
            return 1;
        }

        ### return if we're only supposed to report make_test failures ###
        return 1 if $cp_conf =~  /\bmaketest_only\b/i
                    and ($stage !~ /\btest\b/);

        ### the bit where we inform what went wrong
        $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );

        ### was it missing prereqs? ###
        if( my @missing = MISSING_PREREQS_LIST->($buffer) ) {
            if(!$self->_verify_missing_prereqs(
                                module  => $mod,
                                missing => \@missing
                        )) {
                msg(loc("Not sending test report - "  .
                        "bogus missing prerequisites report"));
                return 1;
            }
            $message .= REPORT_MISSING_PREREQS->($author,$email,@missing);
        }

        ### was it missing test files? ###
        if( NO_TESTS_DEFINED->($buffer) ) {
            $message .= REPORT_MISSING_TESTS->();
        }

        ### add a list of what modules have been loaded of your prereqs list
        $message .= REPORT_LOADED_PREREQS->($mod);

        ### the footer
        $message .= REPORT_MESSAGE_FOOTER->();

    ### it may be another grade than fail/unknown.. may be worth noting
    ### that tests got skipped, since the buffer is not added in
    } elsif ( $tests_skipped ) {
        $message .= REPORT_TESTS_SKIPPED->();
    } elsif( $grade eq GRADE_NA) {
    
        ### the bit where we inform what went wrong
        $message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );

        ### the footer
        $message .= REPORT_MESSAGE_FOOTER->();

    }

    msg( loc("Sending test report for '%1'", $dist), $verbose);

    ### reporter object ###
    my $reporter = do {
        my $args = $conf->get_conf('cpantest_reporter_args') || {};
        
        unless( UNIVERSAL::isa( $args, 'HASH' ) ) {
            error(loc("'%1' must be a hashref, ignoring...",
                      'cpantest_reporter_args'));
            $args = {};
        }
        
        Test::Reporter->new(
            grade           => $grade,
            distribution    => $dist,
            via             => "CPANPLUS $int_ver",
            timeout         => $conf->get_conf('timeout') || 60,
            debug           => $conf->get_conf('debug'),
            %$args,
        );
    };
    
    ### set a custom mx, if requested
    $reporter->mx( [ $conf->get_conf('cpantest_mx') ] ) 
        if $conf->get_conf('cpantest_mx');

    ### set the from address ###
    $reporter->from( $conf->get_conf('email') )
        if $conf->get_conf('email') !~ /\@example\.\w+$/i;

    ### give the user a chance to programattically alter the message
    $message = $self->_callbacks->munge_test_report->($mod, $message, $grade);

    ### add the body if we have any ###
    $reporter->comments( $message ) if defined $message && length $message;

    ### do a callback to ask if we should send the report
    unless ($self->_callbacks->send_test_report->($mod, $grade)) {
        msg(loc("Ok, not sending test report"));
        return 1;
    }

    ### do a callback to ask if we should edit the report
    if ($self->_callbacks->edit_test_report->($mod, $grade)) {
        ### test::reporter 1.20 and lower don't have a way to set
        ### the preferred editor with a method call, but it does
        ### respect your env variable, so let's set that.
        local $ENV{VISUAL} = $conf->get_program('editor')
                                if $conf->get_program('editor');

        $reporter->edit_comments;
    }

    ### allow to be overridden, but default to the normal address ###
    $reporter->address( $address );

    ### should we save it locally? ###
    if( $save ) {
        if( my $file = $reporter->write() ) {
            msg(loc("Successfully wrote report for '%1' to '%2'",
                    $dist, $file), $verbose);
            return $file;

        } else {
            error(loc("Failed to write report for '%1'", $dist));
            return;
        }

    ### XXX should we do an 'already sent' check? ###
    } elsif( $reporter->send( ) ) {
        msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist),
            $verbose);
        return 1;

    ### something broke :( ###
    } else {
        error(loc("Could not send '%1' report for '%2': %3",
                $grade, $dist, $reporter->errstr));
        return;
    }
}

sub _verify_missing_prereqs {
    my $self = shift;
    my %hash = @_;

    ### check arguments ###
    my ($mod, $missing);
    my $tmpl = {
            module  => { required => 1, store => \$mod },
            missing => { required => 1, store => \$missing },
    };

    check( $tmpl, \%hash ) or return;

    
    my %missing = map {$_ => 1} @$missing;
    my $conf = $self->configure_object;
    my $extract = $mod->status->extract;

    ### Read pre-requisites from Makefile.PL or Build.PL (if there is one),
    ### of the form:
    ###     'PREREQ_PM' => {
    ###                      'Compress::Zlib'        => '1.20',
    ###                      'Test::More'            => 0,
    ###                    },
    ###  Build.PL uses 'requires' instead of 'PREREQ_PM'.

    my @search;
    push @search, ($extract ? MAKEFILE_PL->( $extract ) : MAKEFILE_PL->());
    push @search, ($extract ? BUILD_PL->( $extract ) : BUILD_PL->());

    for my $file ( @search ) {
        if(-e $file and -r $file) {
            my $slurp = $self->_get_file_contents(file => $file);
            my ($prereq) = 
                ($slurp =~ /'?(?:PREREQ_PM|requires)'?\s*=>\s*{(.*?)}/s);
            my @prereq = 
                ($prereq =~ /'?([\w\:]+)'?\s*=>\s*'?\d[\d\.\-\_]*'?/sg);
            delete $missing{$_} for(@prereq);
        }
    }

    return 1    if(keys %missing);  # There ARE missing prerequisites
    return;                         # All prerequisites accounted for
}

1;


# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4:
Commit	Line	Data
6aaee015	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];
6aaee015	12	use Module::Load::Conditional qw[can_load];
5bc5f6dc	13	use Locale::Maketext::Simple Class => 'CPANPLUS', Style => 'gettext';
6aaee015	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
5879cbe1	55
	56	### XXX remove this list and move it into selfupdate, somehow..
	57	### this is dual administration
6aaee015	58	{ my $query_list = {
5879cbe1	59	'File::Fetch' => '0.13_02',
5bc5f6dc	60	'YAML::Tiny' => '0.0',
5bc5f6dc	61	'File::Temp' => '0.0',
6aaee015	62	};
	63
	64	my $send_list = {
	65	%$query_list,
5bc5f6dc	66	'Test::Reporter' => '1.34',
6aaee015	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,
4443dd53	106	module names or distributions.
6aaee015	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
4443dd53	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:
6aaee015	116
	117	{
	118	'grade' => 'PASS',
	119	'dist' => 'CPANPLUS-0.042',
	120	'platform' => 'i686-pld-linux-thread-multi'
4443dd53	121	'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/98316'
4443dd53	122	...
6aaee015	123	},
	124	{
	125	'grade' => 'PASS',
	126	'dist' => 'CPANPLUS-0.042',
	127	'platform' => 'i686-linux-thread-multi'
4443dd53	128	'details' => 'http://nntp.x.perl.org/group/perl.cpan.testers/99416'
4443dd53	129	...
6aaee015	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'
4443dd53	136	...
6aaee015	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'
4443dd53	143	...
6aaee015	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
6aaee015	170
5bc5f6dc	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	#
6aaee015	176	### set proxies if we have them ###
5bc5f6dc	177	# $ua->env_proxy();
6aaee015	178
6aaee015	179	my $url = TESTERS_URL->($mod->package_name);
5bc5f6dc	180	my $ff = File::Fetch->new( uri => $url );
6aaee015	181
	182	msg( loc("Fetching: '%1'", $url), $verbose );
	183
5bc5f6dc	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	}
6aaee015	193
5bc5f6dc	194	my $fh = OPEN_FILE->( $where );
	195
	196	do { local $/; <$fh> };
	197	};
	198
	199	my ($aref) = eval { YAML::Tiny::Load( $res ) };
6aaee015	200
5bc5f6dc	201	if( $@ ) {
	202	error(loc("Error reading result: %1", $@));
	203	return;
	204	};
6aaee015	205
4443dd53	206	my $dist = $mod->package_name .'-'. $mod->package_version;
4443dd53	207	my $details = TESTERS_DETAILS_URL->($mod->package_name);
6aaee015	208
	209	my @rv;
	210	for my $href ( @$aref ) {
	211	next unless $all or defined $href->{'distversion'} &&
	212	$href->{'distversion'} eq $dist;
	213
4443dd53	214	$href->{'details'} = $details;
	215
	216	### backwards compatibility :(
a3de5d0b	217	$href->{'dist'} \|\|= $href->{'distversion'};
a3de5d0b	218	$href->{'grade'} \|\|= $href->{'action'} \|\| $href->{'status'};
4443dd53	219
4443dd53	220	push @rv, $href;
6aaee015	221	}
	222
	223	return @rv if @rv;
	224	return;
	225	}
	226
	227	=pod
	228
4443dd53	229	=head2 $bool = $cb->_send_report( module => $modobj, buffer => $make_output, failed => BOOL, [save => BOOL, address => $email_to, verbose => BOOL, force => BOOL]);
6aaee015	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
6aaee015	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 ###
4443dd53	298	my ($buffer, $failed, $mod, $verbose, $force, $address, $save,
6aaee015	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 },
6aaee015	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
4443dd53	326	### will be 'fetch', 'make', 'test', 'install', etc ###
	327	my $stage = TEST_FAIL_STAGE->($buffer);
	328
6aaee015	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 );
4443dd53	351	my $sub = CPANPLUS::Module->can(
4443dd53	352	'module_is_supplied_with_perl_core' );
6aaee015	353
4443dd53	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 ) ) {
6aaee015	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;
4443dd53	409	### failures in PL or make/build stage are now considered UNKNOWN
	410	} elsif ( $stage !~ /\btest\b/ ) {
	411
	412	$grade = GRADE_UNKNOWN
6aaee015	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 ###
4443dd53	426
	427	### the header -- always include so the CPANPLUS version is apparent
	428	my $message = REPORT_MESSAGE_HEADER->( $int_ver, $author );
	429
6aaee015	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
6aaee015	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
6aaee015	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
5bc5f6dc	468	$message .= REPORT_MESSAGE_FOOTER->();
6aaee015	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->();
4443dd53	474	} elsif( $grade eq GRADE_NA) {
	475
	476	### the bit where we inform what went wrong
	477	$message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $buffer );
6aaee015	478
4443dd53	479	### the footer
4443dd53	480	$message .= REPORT_MESSAGE_FOOTER->();
6aaee015	481
6aaee015	482	}
4443dd53	483
5bc5f6dc	484	msg( loc("Sending test report for '%1'", $dist), $verbose);
6aaee015	485
6aaee015	486	### reporter object ###
4443dd53	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
6aaee015	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
6aaee015	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
6aaee015	552	### XXX should we do an 'already sent' check? ###
4443dd53	553	} elsif( $reporter->send( ) ) {
6aaee015	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: