New tlperl part XIII

git-svn-id: svn://tug.org/texlive/trunk@21435 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 645 insertions, 0 deletions

diff --git a/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm
new file mode 100644
index 00000000000..774c6b91a02
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/CPANPLUS/Internals/Report.pm
@@ -0,0 +1,645 @@
+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',
+        'Parse::CPAN::Meta'    => '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 { 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 );
+    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( !$obj and !$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 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);
+
+        ### 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) {
+    
+        ### 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? ###
+    ### 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: