File Coverage

blib/lib/CPAN/Testers/Common/Client.pm

Criterion	Covered	Total	%
statement	223	245	91.0
branch	60	84	71.4
condition	27	44	61.3
subroutine	44	45	97.7
pod	12	12	100.0
total	366	430	85.1

# TODO: several resources per client?
package CPAN::Testers::Common::Client;
use warnings;
use strict;

use Devel::Platform::Info;
use Probe::Perl;
use Config::Perl::V;
use Carp ();
use File::Spec;
use Capture::Tiny qw(capture);
use CPAN::Testers::Common::Client::PrereqCheck;
use CPAN::Testers::Common::Client::History;

use constant MAX_OUTPUT_LENGTH => 1_000_000;

our $VERSION = '0.13';


#==================================
#  CONSTRUCTOR
#==================================

sub new {
    my ($class, %params) = @_;
    my $self  = bless {}, $class;

    Carp::croak q[Please specify a distname]           unless $params{distname};
    Carp::croak q[Please specify the dist's author]    unless $params{author};
    Carp::croak q[Please specify a grade for the dist] unless $params{grade};

    $self->_init( %params );

    return $self;
}

sub _init {
    my ($self, %params) = @_;

    $self->grade( $params{grade} );
    $self->distname( $params{distname} );
    $self->author( $params{author} );

    $self->via( exists $params{via}
                ? $params{via}
                : "your friendly CPAN Testers client version $VERSION"
              );

    $self->comments( exists $params{comments}
                     ? $params{comments}
                     : $ENV{AUTOMATED_TESTING}
                     ? "this report is from an automated smoke testing program\nand was not reviewed by a human for accuracy"
                     : 'none provided'
                   );

    $self->command( $params{command} ) if exists $params{command};

    if ( $params{prereqs} ) {
        $self->{_meta}{prereqs} = $params{prereqs}
    }
    elsif ( $params{build_dir} ) {
        $self->_get_prereqs( $params{build_dir} );
    }

    foreach my $output ( qw( configure build test ) ) {
        my $key = $output . '_output';
        if (exists $params{$key}) {
            $self->{_output}{$output} = $params{$key};
        }
    }

    return;
}


#======================================
#  ACCESSORS
#======================================

sub comments {
    my ($self, $comment) = @_;
    $self->{_comment} = $comment if $comment;
    return $self->{_comment};
}

sub via {
    my ($self, $via) = @_;
    $self->{_via} = $via if $via;
    return $self->{_via};
}

sub author {
    my ($self, $author) = @_;
    $self->{_author} = $author if $author;
    return $self->{_author};
}


#FIXME? the distname in CPAN::Reporter is validated
# under a specific regex in line 368. We should
# move that logic here.
sub distname {
    my ($self, $distname) = @_;
    $self->{_distname} = $distname if $distname;

    return $self->{_distname};
}

sub grade {
    my ($self, $grade) = @_;
    $self->{_grade} = lc $grade if $grade;
    return $self->{_grade};
}

sub command {
    my ($self, $command) = @_;
    $self->{_command} = $command if $command;
    return $self->{_command} || '';
}

#====================================
#  PUBLIC METHODS
#====================================

sub is_duplicate {
    my ($self) = @_;

    my $grade     = $self->grade;
    my $dist_name = $self->distname;
    return 0 unless $grade && $dist_name;

    #FIXME: CPAN::Reporter allows for 3 phases: 'PL', 'make' or 'test'.
    # Until this is properly ported, we'll only use the 'test' phase.
    return CPAN::Testers::Common::Client::History::is_duplicate({
        phase     => 'test',
        grade     => $grade,
        dist_name => $dist_name,
    });
}

sub record_history {
    my ($self) = @_;

    my $grade     = $self->grade;
    my $dist_name = $self->distname;
    return unless $grade && $dist_name;

    #FIXME: CPAN::Reporter allows for 3 phases: 'PL', 'make' or 'test'.
    # Until this is properly ported, we'll only use the 'test' phase.
    return CPAN::Testers::Common::Client::History::record_history({
        phase     => 'test',
        grade     => $grade,
        dist_name => $dist_name,
    });
}

sub populate {
    my $self = shift;

    # some data is repeated between facts, so we keep a 'cache'
    $self->{_config}   = Config::Perl::V::myconfig();
    $self->{_platform} = Devel::Platform::Info->new->get_info();

    # LegacyReport creates the email, therefore it must
    # be set last so all other data is already in place.
    my @facts = qw(
        TestSummary TestOutput TesterComment
        Prereqs InstalledModules
        PlatformInfo PerlConfig TestEnvironment
        LegacyReport
    );

    foreach my $fact ( @facts ) {
        my $populator = '_populate_' . lc $fact;
        $self->{_data}{$fact} = $self->$populator;
    }

    return $self->metabase_data;
}

sub metabase_data { return shift->{_data} }

sub email {
    my $self = shift;
    my $metabase_data = $self->metabase_data || $self->populate;

    return $metabase_data->{LegacyReport}{textreport};
}


#===================================================
# POPULATORS -- these functions populate
# the object with data, triggered by the
# populate() method.
#===================================================

sub _populate_platforminfo {
    my $self = shift;
    return $self->{_platform};
}


sub _populate_perlconfig {
    my $self = shift;
    return @{ $self->{_config} }{qw(build config)};
}

sub _populate_testenvironment {

    return {
        environment_vars => _get_env_vars(),
        special_vars     => _get_special_vars(),
    };
}

sub _populate_prereqs {
    my $self = shift;

    # TODO: update Fact::Prereqs to use the new meta::spec for prereqs
    # TODO: add the 'test' prereqs?
    return $self->{_meta}{prereqs}
        || {
              runtime   => { requires => {} },
              build     => { requires => {} },
              configure => { requires => {} },
           };
    #{
    #    configure_requires => $self->{_meta}{configure_requires} || {},
    #    build_requires     => $self->{_meta}{build_requires}     || {},
    #    requires           => $self->{_meta}{requires}           || {},
    #};
}

sub _populate_testercomment {
    my $self = shift;
    return $self->comments;
}

sub _populate_installedmodules {
    my $self = shift;

    my @toolchain_mods= qw(
        CPAN
        CPAN::Meta
        Cwd
        ExtUtils::CBuilder
        ExtUtils::Command
        ExtUtils::Install
        ExtUtils::MakeMaker
        ExtUtils::Manifest
        ExtUtils::ParseXS
        File::Spec
        JSON
        JSON::PP
        Module::Build
        Module::Signature
        Parse::CPAN::Meta
        Test::Harness
        Test::More
        YAML
        YAML::Syck
        version
    );

    my $results = _version_finder( map { $_ => 0 } @toolchain_mods );

    my %toolchain = map { $_ => $results->{$_}{have} } @toolchain_mods;
    my %prereqs = ();

    return { prereqs => \%prereqs, toolchain => \%toolchain };
}


sub _populate_legacyreport {
    my $self = shift;
    return {
        %{ $self->_populate_testsummary },
        textreport => $self->_create_email,
    }
}

sub _populate_testsummary {
    my $self = shift;

    return {
        grade        => $self->grade,
        osname       => $self->{_platform}{osname},
        osversion    => $self->{_platform}{osvers},
        archname     => $self->{_platform}{archname},
        perl_version => $self->{_config}{config}{version},
    }
}

sub _populate_testoutput {
    my $self = shift;
    return $self->{_output};
}


#=====================================================
#  FORMATTERS -- functions to aid email formatting
#=====================================================

sub _format_vars_report {
    my $variables = shift;

    my $report = "";
    foreach my $var ( sort keys %$variables ) {
        my $value = $variables->{$var};
        $value = '[undef]' if ! defined $value;
        $report .= "    $var = $value\n";
    }
    return $report;
}

sub _fix_unknown { defined $_[0] ? $_[0] : 'unknown' }

sub _format_toolchain_report {
    my $installed = shift;
    my $mod_width = _max_length( keys %$installed );
    my $ver_width = _max_length(
        map { _fix_unknown( $installed->{$_} ) } keys %$installed
    );

    my $format = "    \%-${mod_width}s \%-${ver_width}s\n";

    my $report = "";
    $report .= sprintf( $format, "Module", "Have" );
    $report .= sprintf( $format, "-" x $mod_width, "-" x $ver_width );

    for my $var ( sort keys %$installed ) {
        $report .= sprintf("    \%-${mod_width}s \%-${ver_width}s\n",
                            $var, _fix_unknown($installed->{$var}) );
    }

    return $report;
}

sub _format_prereq_report {
    my $prereqs = shift;
    my (%have, %prereq_met, $report);

    my @prereq_sections = qw( runtime build configure );

    # see what prereqs are satisfied in subprocess
    foreach my $section ( @prereq_sections ) {
        my $requires = $prereqs->{$section}{requires};
        next unless $requires and ref $requires eq 'HASH' and keys %$requires > 0;

        my $results = _version_finder( %$requires );

        foreach my $mod ( keys %$results ) {
            $have{$section}{$mod} = $results->{$mod}{have};
            $prereq_met{$section}{$mod} = $results->{$mod}{met};
        }
    }

    # find formatting widths
    my ($name_width, $need_width, $have_width) = (6, 4, 4);
    foreach my $section ( @prereq_sections ) {
        my $requires = $prereqs->{$section}{requires};
        next unless $requires and ref $requires eq 'HASH';

        foreach my $module ( keys %$requires ) {
            my $name_length = length $module;
            my $need_length = length $requires->{$module};
            my $have_length = length _fix_unknown( $have{$section}{$module} );
            $name_width = $name_length if $name_length > $name_width;
            $need_width = $need_length if $need_length > $need_width;
            $have_width = $have_length if $have_length > $have_width;
        }
    }

    my $format_str =
        "  \%1s \%-${name_width}s \%-${need_width}s \%-${have_width}s\n";

    # generate the report
    foreach my $section ( @prereq_sections ) {
      my $requires = $prereqs->{$section}{requires};
      next unless $requires and ref $requires eq 'HASH' and keys %$requires;

      $report .= "$section:\n\n"
              .  sprintf( $format_str, " ", qw/Module Need Have/ )
              .  sprintf( $format_str, " ",
                          "-" x $name_width,
                          "-" x $need_width,
                          "-" x $have_width
              );

      foreach my $module ( sort {lc $a cmp lc $b} keys %$requires ) {
        my $need = $requires->{$module};
        my $have = _fix_unknown( $have{$section}{$module} );
        my $bad = $prereq_met{$section}{$module} ? " " : "!";
        $report .= sprintf( $format_str, $bad, $module, $need, $have);
      }
      $report .= "\n";
    }

    return $report || "    No requirements found\n";
}


#==============================================
# AUXILIARY (PRIVATE) METHODS AND FUNCTIONS
#==============================================

sub _get_env_vars {
    # Entries bracketed with "/" are taken to be a regex; otherwise literal
    my @env_vars= qw(
        /HARNESS/
        /LC_/
        /PERL/
        /_TEST/
        CCFLAGS
        COMSPEC
        INCLUDE
        INSTALL_BASE
        LANG
        LANGUAGE
        LD_LIBRARY_PATH
        LDFLAGS
        LIB
        NON_INTERACTIVE
        NUMBER_OF_PROCESSORS
        PATH
        PREFIX
        PROCESSOR_IDENTIFIER
        SHELL
        TERM
        TEMP
        TMPDIR
    );

    my %env_found = ();
    foreach my $var ( @env_vars ) {
        if ( $var =~ m{^/(.+)/$} ) {
            my $re = $1;
            foreach my $found ( grep { /$re/ } keys %ENV ) {
                $env_found{$found} = $ENV{$found} if exists $ENV{$found};
            }
        }
        else {
            $env_found{$var} = $ENV{$var} if exists $ENV{$var};
        }
    }

    return \%env_found;
}

sub _get_special_vars {
    my %special_vars = (
        EXECUTABLE_NAME => $^X,
        UID             => $<,
        EUID            => $>,
        GID             => $(,
        EGID            => $),
    );

    if ( $^O eq 'MSWin32' && eval 'require Win32' ) { ## no critic
        $special_vars{'Win32::GetOSName'}    = Win32::GetOSName();
        $special_vars{'Win32::GetOSVersion'} = join( ', ', Win32::GetOSVersion() );
        $special_vars{'Win32::FsType'}       = Win32::FsType();
        $special_vars{'Win32::IsAdminUser'}  = Win32::IsAdminUser();
    }
    return \%special_vars;
}

sub _get_prereqs {
    my ($self, $dir) = @_;
    my $meta;

    foreach my $meta_file ( qw( META.json META.yml META.yaml ) ) {
        my $meta_path = File::Spec->catfile( $dir, $meta_file );
        if (-e $meta_path) {
            $meta = eval { Parse::CPAN::Meta->load_file( $dir ) };
            last if $meta;
        }
    }

    if ($meta and $meta->{'meta-spec'}{version} < 2) {
        $self->{_meta}{prereqs} = $meta->{prereqs};
    }
    return;
}

sub _max_length {
    my ($first, @rest) = @_;
    my $max = length $first;
    for my $term ( @rest ) {
        $max = length $term if length $term > $max;
    }
    return $max;
}

#--------------------------------------------------------------------------#
# _temp_filename -- stand-in for File::Temp for backwards compatibility
#
# takes an optional prefix, adds 8 random chars and returns
# an absolute pathname
#
# NOTE -- manual unlink required
#--------------------------------------------------------------------------#

sub _temp_filename {
    my ($prefix) = @_;
    # @CHARS from File::Temp
    my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
                 a b c d e f g h i j k l m n o p q r s t u v w x y z
                 0 1 2 3 4 5 6 7 8 9 _
             /);

    $prefix = q{} unless defined $prefix;
    $prefix .= $CHARS[ int( rand(@CHARS) ) ] for 0 .. 7;
    return File::Spec->catfile(File::Spec->tmpdir(), $prefix);
}


#--------------------------------------------------------------------------#
# _version_finder
#
# module => version pairs
#
# This is done via an external program to show installed versions exactly
# the way they would be found when test programs are run.  This means that
# any updates to PERL5LIB will be reflected in the results.
#
# File-finding logic taken from CPAN::Module::inst_file().  Logic to
# handle newer Module::Build prereq syntax is taken from
# CPAN::Distribution::unsat_prereq()
#
#--------------------------------------------------------------------------#
my $version_finder = $INC{'CPAN/Testers/Common/Client/PrereqCheck.pm'};

sub _version_finder {
    my %prereqs = @_;

    my $perl = Probe::Perl->find_perl_interpreter();
    my @prereq_results;

    my $prereq_input = _temp_filename( 'CTCC-' );
    open my $fh, '>', $prereq_input
        or die "Could not create temporary '$prereq_input' for prereq analysis: $!";
    print {$fh} map { "$_ $prereqs{$_}\n" } keys %prereqs;
    close $fh;

    my ( $prereq_result, $error, $exit ) = capture { system( $perl, $version_finder, $prereq_input ) };
    unlink $prereq_input;

    if ( length $error ) {
      print STDERR $error;
    }
    if ( not length $prereq_result) {
      warn "Got no output from CPAN::Testers::Common::Client::PrereqCheck";
    }
    my %result;
    for my $line ( split "\n", $prereq_result ) {
        next unless length $line;
        my ($mod, $met, $have) = split " ", $line;
        unless ( defined($mod) && defined($met) && defined($have) ) {
            warn "Error parsing output from CPAN::Testers::Common::Client::PrereqCheck:\n$line";
            next;
        }
        $result{$mod}{have} = $have;
        $result{$mod}{met} = $met;
    }
    return \%result;
}


sub _create_email {
    my $self = shift;

    my %intro_para = (
    'pass' => <<'HERE',
Thank you for uploading your work to CPAN.  Congratulations!
All tests were successful.
HERE

    'fail' => <<'HERE',
Thank you for uploading your work to CPAN.  However, there was a problem
testing your distribution.

If you think this report is invalid, please consult the CPAN Testers Wiki
for suggestions on how to avoid getting FAIL reports for missing library
or binary dependencies, unsupported operating systems, and so on:

http://wiki.cpantesters.org/wiki/CPANAuthorNotes
HERE

    'unknown' => <<'HERE',
Thank you for uploading your work to CPAN.  However, attempting to
test your distribution gave an inconclusive result.

This could be because your distribution had an error during the make/build
stage, did not define tests, tests could not be found, because your tests were
interrupted before they finished, or because the results of the tests could not
be parsed.  You may wish to consult the CPAN Testers Wiki:

http://wiki.cpantesters.org/wiki/CPANAuthorNotes
HERE

    'na' => <<'HERE',
Thank you for uploading your work to CPAN.  While attempting to build or test
this distribution, the distribution signaled that support is not available
either for this operating system or this version of Perl.  Nevertheless, any
diagnostic output produced is provided below for reference.  If this is not
what you expect, you may wish to consult the CPAN Testers Wiki:

http://wiki.cpantesters.org/wiki/CPANAuthorNotes
HERE

);

    my $metabase_data = $self->metabase_data;
    my %data = (
        author             => $self->author,
        dist_name          => $self->distname,
        perl_version       => $metabase_data->{TestSummary}{perl_version},
        via                => $self->via,
        grade              => $self->grade,
        comment            => $self->comments,
        command            => $self->command,
        test_log           => $metabase_data->{TestOutput}{test} || '',
        prereq_pm          => _format_prereq_report( $metabase_data->{Prereqs} ),
        env_vars           => _format_vars_report( $metabase_data->{TestEnvironment}{environment_vars} ),
        special_vars       => _format_vars_report( $metabase_data->{TestEnvironment}{special_vars} ),
        toolchain_versions => _format_toolchain_report( $metabase_data->{InstalledModules}{toolchain} ),
    );

    if ( length $data{test_log} > MAX_OUTPUT_LENGTH ) {
        my $max_k = int(MAX_OUTPUT_LENGTH/1000) . "K";
        $data{test_log} = substr( $data{test_log}, 0, MAX_OUTPUT_LENGTH)
                        . "\n\n[Output truncated after $max_k]\n\n";
    }

    return <<"EOEMAIL";
Dear $data{author},

This is a computer-generated report for $data{dist_name}
on perl $data{perl_version}, created by $data{via}.

$intro_para{ $data{grade} }
Sections of this report:

    * Tester comments
    * Program output
    * Prerequisites
    * Environment and other context

------------------------------
TESTER COMMENTS
------------------------------

Additional comments from tester:

$data{comment}

------------------------------
PROGRAM OUTPUT
------------------------------

Output from '$data{command}':

$data{test_log}
------------------------------
PREREQUISITES
------------------------------

Prerequisite modules loaded:

$data{prereq_pm}
------------------------------
ENVIRONMENT AND OTHER CONTEXT
------------------------------

Environment variables:

$data{env_vars}
Perl special variables (and OS-specific diagnostics, for MSWin32):

$data{special_vars}
Perl module toolchain versions installed:

$data{toolchain_versions}
EOEMAIL

}

42;
__END__