Initial Commit
This commit is contained in:
Riley Schneider
695
database/perl/vendor/lib/CPANPLUS/Internals/Report.pm
vendored
Normal file
695
database/perl/vendor/lib/CPANPLUS/Internals/Report.pm
vendored
Normal file
@@ -0,0 +1,695 @@
|
||||
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';
|
||||
use version;
|
||||
|
||||
use vars qw[$VERSION];
|
||||
$VERSION = "0.9910";
|
||||
|
||||
$Params::Check::VERBOSE = 1;
|
||||
|
||||
### for the version ###
|
||||
require CPANPLUS::Internals;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
CPANPLUS::Internals::Report - internals for sending test reports
|
||||
|
||||
=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',
|
||||
'Parse::CPAN::Meta' => '0.0',
|
||||
'File::Temp' => '0.0',
|
||||
};
|
||||
|
||||
my $send_list = {
|
||||
%$query_list,
|
||||
'Test::Reporter' => '1.54',
|
||||
};
|
||||
|
||||
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 { Parse::CPAN::Meta::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, $status );
|
||||
my $tmpl = {
|
||||
module => { required => 1, store => \$mod, allow => IS_MODOBJ },
|
||||
buffer => { required => 1, store => \$buffer },
|
||||
failed => { required => 1, store => \$failed },
|
||||
status => { default => {}, store => \$status, strict_type => 1 },
|
||||
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 $distfile= $mod->author->cpanid . "/" . $mod->package;
|
||||
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 instead
|
||||
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 || {};
|
||||
|
||||
PREREQ: while( my($prq_name,$prq_ver) = each %$prq ) {
|
||||
|
||||
# 'perl' listed as prereq
|
||||
|
||||
if ( $prq_name eq 'perl' ) {
|
||||
my $req_ver = eval { version->new( $prq_ver ) };
|
||||
next PREREQ unless $req_ver;
|
||||
if ( version->new( $] ) < $req_ver ) {
|
||||
msg(loc("'%1' requires a higher version of perl than your current ".
|
||||
"version -- sending N/A grade.", $name), $verbose);
|
||||
|
||||
$grade = GRADE_NA;
|
||||
last GRADE;
|
||||
}
|
||||
next PREREQ;
|
||||
}
|
||||
|
||||
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( !$obj and !defined $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 ( !$obj ) {
|
||||
my $vcore = $sub->( $prq_name );
|
||||
if ( $cb->_vcmp( $prq_ver, $vcore ) > 0 ) {
|
||||
msg(loc( "Version of core module '%1' ('%2') is too low for ".
|
||||
"'%3' (needs '%4') -- sending N/A grade",
|
||||
$prq_name, $vcore,
|
||||
$name, $prq_ver ), $verbose );
|
||||
|
||||
$grade = GRADE_NA;
|
||||
last GRADE;
|
||||
}
|
||||
}
|
||||
|
||||
if( $obj and $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 don't 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/);
|
||||
|
||||
my $capture = ( $status && defined $status->{capture} ? $status->{capture} : $buffer );
|
||||
### the bit where we inform what went wrong
|
||||
$message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $capture );
|
||||
|
||||
### 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);
|
||||
|
||||
### add a list of versions of toolchain modules
|
||||
$message .= REPORT_TOOLCHAIN_VERSIONS->($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) {
|
||||
|
||||
my $capture = ( $status && defined $status->{capture} ? $status->{capture} : $buffer );
|
||||
|
||||
### add the reason for the NA to the buffer
|
||||
$capture = join $/, $capture, map {
|
||||
'[' . $_->tag . '] [' . $_->when . '] ' .
|
||||
$_->message } ( CPANPLUS::Error->stack )[-1];
|
||||
|
||||
### the bit where we inform what went wrong
|
||||
$message .= REPORT_MESSAGE_FAIL_HEADER->( $stage, $capture );
|
||||
|
||||
### add a list of what modules have been loaded of your prereqs list
|
||||
$message .= REPORT_LOADED_PREREQS->($mod);
|
||||
|
||||
### add a list of versions of toolchain modules
|
||||
$message .= REPORT_TOOLCHAIN_VERSIONS->($mod);
|
||||
|
||||
### the footer
|
||||
$message .= REPORT_MESSAGE_FOOTER->();
|
||||
|
||||
} elsif ( $grade eq GRADE_PASS and ( $status and defined $status->{capture} ) ) {
|
||||
### the bit where we inform what went right
|
||||
$message .= REPORT_MESSAGE_PASS_HEADER->( $stage, $status->{capture} );
|
||||
|
||||
### add a list of what modules have been loaded of your prereqs list
|
||||
$message .= REPORT_LOADED_PREREQS->($mod);
|
||||
|
||||
### add a list of versions of toolchain modules
|
||||
$message .= REPORT_TOOLCHAIN_VERSIONS->($mod);
|
||||
|
||||
### 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,
|
||||
distfile => $distfile,
|
||||
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 programmatically 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? ###
|
||||
### something broke :( ###
|
||||
}
|
||||
else {
|
||||
my $status;
|
||||
eval {
|
||||
$status = $reporter->send();
|
||||
};
|
||||
if ( $@ ) {
|
||||
error(loc("Could not send '%1' report for '%2': %3",
|
||||
$grade, $dist, $@));
|
||||
return;
|
||||
}
|
||||
if ( $status ) {
|
||||
msg(loc("Successfully sent '%1' report for '%2'", $grade, $dist),
|
||||
$verbose);
|
||||
return 1;
|
||||
}
|
||||
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:
|
||||
Reference in New Issue
Block a user