File Coverage

blib/lib/Test/DependentModules.pm

Criterion	Covered	Total	%
statement	85	271	31.3
branch	10	76	13.1
condition	1	21	4.7
subroutine	27	54	50.0
pod	3	3	100.0
total	126	425	29.6

package Test::DependentModules;

use strict;
use warnings;
use autodie;

our $VERSION = '0.26';

# CPAN::Reporter spits out random output we don't want, and we don't want to
# report these tests anyway.
BEGIN {
    ## no critic (Variables::RequireLocalizedPunctuationVars)
    $INC{'CPAN/Reporter.pm'} = 0;
}

use Capture::Tiny qw( capture );
use Cwd qw( abs_path );
use Exporter qw( import );
use File::Path qw( rmtree );
use File::Spec;
use File::Temp qw( tempdir );
use File::chdir;
use IO::Handle::Util qw( io_from_write_cb );
use IPC::Run3 qw( run3 );
use Log::Dispatch;
use MetaCPAN::Client;
use Test::Builder;
use Try::Tiny;

our @EXPORT_OK = qw( test_all_dependents test_module test_modules );

## no critic (Variables::RequireLocalizedPunctuationVars)
$ENV{PERL5LIB} = join q{:}, ( $ENV{PERL5LIB} || q{} ),
    File::Spec->catdir( _temp_lib_dir(), 'lib', 'perl5' );
$ENV{PERL_AUTOINSTALL}    = '--defaultdeps';
$ENV{PERL_MM_USE_DEFAULT} = 1;
## use critic

my $Test = Test::Builder->new;

sub test_all_dependents {
    my $module = shift;
    my $params = shift;

    _load_cpan();
    _make_logs();

    my @deps = _get_deps( $module, $params );

    $Test->plan( tests => scalar @deps );

    local $Test::Builder::Level = $Test::Builder::Level + 1;
    test_modules(@deps);
}

sub _get_deps {
    my $module = shift;
    my $params = shift;

    $module =~ s/::/-/g;

    my $rev_deps = MetaCPAN::Client->new->rev_deps($module);

    my $allow
        = $params->{filter} ? $params->{filter}
        : $params->{exclude} ? sub { $_[0] !~ /$params->{exclude}/ }
        :                      sub {1};

    my @deps;
    while ( my $dep = $rev_deps->next ) {
        my $dist = $dep->distribution;

        next unless $allow->($dist);
        next if $dist =~ /^(?:Task|Bundle)/;

        push @deps => $dist;
    }

    ## no critic (Subroutines::ProhibitReturnSort)
    return sort { lc $a cmp lc $b } @deps;
}

sub test_modules {
    _load_cpan();
    _make_logs();

    my $parallel = 0;
    if (   $ENV{PERL_TEST_DM_PROCESSES}
        && $ENV{PERL_TEST_DM_PROCESSES} > 1 ) {

        if ( eval { require Parallel::ForkManager; 1; } ) {
            $parallel = 1;
        }
        else {
            warn
                'Cannot run multiple processes without the Parallel::ForkManager module.';
        }
    }

    if ($parallel) {
        _test_in_parallel(@_);
    }
    else {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        for my $module (@_) {
            test_module($module);
        }
    }
}

sub _test_in_parallel {
    my @modules = @_;

    my $pm = Parallel::ForkManager->new( $ENV{PERL_TEST_DM_PROCESSES} );

    $pm->run_on_finish(
        sub {
            shift;    # pid
            shift;    # program exit code
            shift;    # ident
            shift;    # exit signal
            shift;    # core dump
            my $results = shift;

            local $Test::Builder::Level = $Test::Builder::Level + 1;
            _test_report($results);
        }
    );

    for my $module (@_) {
        $pm->start and next;

        local $Test::Builder::Level = $Test::Builder::Level + 1;
        test_module( $module, $pm );
    }

    $pm->wait_all_children;
}

sub test_module {
    my $name = shift;
    my $pm   = shift;

    _load_cpan();
    _make_logs();

    $name =~ s/-/::/g;

    my $dist = _get_distro($name);
    unless ($dist) {
        _finish_test(
            $pm,
            {
                name    => $name,
                skipped => qq{Could't find a distro for $name},
            }
        );
        return;
    }

    $Test->diag( 'Testing ' . $dist->base_id );

    unless ($dist) {
        $name =~ s/::/-/g;
        my $todo
            = defined( $Test->todo )
            ? ' (TODO: ' . $Test->todo . ')'
            : q{};
        my $summary = "FAIL${todo}: $name - ??? - ???";
        my $output  = "Could not find $name on CPAN\n";

        _finish_test(
            $pm, {
                name    => $name,
                passed  => 0,
                summary => $summary,
                output  => $output,
                stderr  => $output,
            }
        );
        return;
    }

    $name = $dist->base_id;

    my $success = try {
        capture { _install_prereqs($dist) };
        1;
    }
    catch {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        my $msg = "Installing prereqs for $name failed: $_";
        $msg =~ s/\s*$//;
        $msg =~ s/\n/\t/g;

        _finish_test(
            $pm,
            , {
                name    => $name,
                skipped => $msg,
            }
        );
        return;
    };

    return unless $success;

    my ( $passed, $output, $stderr ) = _run_tests_for_dir( $dist->dir );

    # A lot of modules seem to have cargo-culted a diag() that looks like this
    # ...
    #
    # Testing Foo::Bar 0.01, Perl 5.00801, /usr/bin/perl
    $stderr = q{}
        if defined $stderr && $stderr =~ /\A\# Testing [\w:]+ [^\n]+\Z/;

    my $status = $passed && $stderr ? 'WARN' : $passed ? 'PASS' : 'FAIL';
    if ( my $reason = $Test->todo ) {
        $status .= " (TODO: $reason)";
    }

    my $summary
        = "$status: $name - " . $dist->base_id . ' - ' . $dist->author->id;

    _finish_test(
        $pm,
        {
            name    => $name,
            passed  => $passed,
            summary => $summary,
            output  => $output,
            stderr  => $stderr,
        }
    );
}

sub _finish_test {
    my $pm      = shift;
    my $results = shift;

    if ($pm) {
        $pm->finish( 0, $results );
    }
    else {
        local $Test::Builder::Level = $Test::Builder::Level + 2;
        _test_report($results);
    }
}

## no critic (Subroutines::ProhibitManyArgs)
sub _test_report {
    my $results = shift;

    if ( $results->{skipped} ) {
        _status_log("UNKNOWN: $results->{name} ($results->{skipped})\n");
        _error_log("UNKNOWN: $results->{name} ($results->{skipped})\n");

        $Test->diag("Skipping $results->{name}: $results->{skipped}");
        $Test->skip( $results->{skipped} );
    }
    else {
        _status_log("$results->{summary}\n");
        _error_log("$results->{summary}\n");

        $Test->ok( $results->{passed}, "$results->{name} passed all tests" );
    }

    if ( $results->{passed} || $results->{skipped} ) {
        _error_log("\n");
    }
    else {
        _error_log( q{-} x 50 );
        _error_log("\n");
        _error_log("$results->{output}\n") if defined $results->{output};
        _error_log("$results->{stderr}\n") if defined $results->{stderr};
    }
}

{
    my %logs;

    sub _make_logs {
        return if %logs;

        my $file_class = $ENV{PERL_TEST_DM_PROCESSES}
            && $ENV{PERL_TEST_DM_PROCESSES} > 1 ? 'File::Locked' : 'File';

        for my $type (qw( status error prereq )) {
            $logs{$type} = Log::Dispatch->new(
                outputs => [
                    [
                        $file_class,
                        min_level => 'debug',
                        filename  => _log_filename($type),
                        mode      => 'append',
                    ],
                ],
            );
        }
    }

    sub _status_log {
        $logs{status}->info(@_);
    }

    sub _error_log {
        $logs{error}->info(@_);
    }

    sub _prereq_log {
        $logs{prereq}->info(@_);
    }
}

sub _log_filename {
    my $type = shift;

    return File::Spec->devnull
        unless $ENV{PERL_TEST_DM_LOG_DIR};

    return File::Spec->catfile(
        $ENV{PERL_TEST_DM_LOG_DIR},
        'test-mydeps-' . $$ . q{-} . $type . '.log'
    );
}

sub _get_distro {
    my $name = shift;

    my @mods = CPAN::Shell->expand( 'Module', $name );

    return unless @mods == 1;

    my $dist = $mods[0]->distribution;

    return unless $dist;

    $dist->get;

    return $dist;
}

sub _install_prereqs {
    my $dist = shift;
    my $root_dist = shift || $dist->base_id;

    my $install_dir = _temp_lib_dir();

    ## no critic (Variables::RequireInitializationForLocalVars, Variables::ProhibitPackageVars)
    local $CPAN::Config->{makepl_arg} .= " INSTALL_BASE=$install_dir";
    local $CPAN::Config->{mbuild_install_arg}
        .= " --install_base $install_dir";
    ## use critic

    my $for_dist = $dist->base_id;

    for my $prereq ( $dist->unsat_prereq('configure_requires_later') ) {
        _install_prereq( $prereq->[0], $for_dist, $root_dist );
    }

    $dist->undelay;
    $dist->make;

    for my $prereq ( $dist->unsat_prereq('later') ) {
        _install_prereq( $prereq->[0], $for_dist, $root_dist );
    }

    $dist->undelay;
}

sub _install_prereq {
    my $prereq    = shift;
    my $for_dist  = shift;
    my $root_dist = shift;

    return if $prereq eq 'perl';

    my $for = "for $for_dist";
    if ( $for_dist ne $root_dist ) {
        $for .= " (started with $root_dist)";
    }

    my $dist = _get_distro($prereq);
    if ( !$dist ) {
        _prereq_log("Couldn't find $prereq $for\n");
        next;
    }

    _install_prereqs( $dist, $root_dist );

    my $installing = $dist->base_id;

    _prereq_log("Installing $installing $for\n");

    try {
        $dist->notest;
        $dist->install;
    }
    catch {
        die "Installing $installing for $for_dist failed: $_";
    };
}

{
    my $Dir;
    BEGIN { $Dir = tempdir( CLEANUP => 1 ); }

    sub _temp_lib_dir {
        return $Dir;
    }
}

sub _run_tests_for_dir {
    my $dir = shift;

    local $CWD = $dir;

    if ( -e 'Build.PL' ) {
        return
            unless _run_commands(
            ['./Build'],
            );
    }
    else {
        return
            unless _run_commands(
            ['make'],
            );
    }

    return _run_tests();
}

sub _run_commands {
    for my $cmd (@_) {
        my $output;

        my $success = try {
            run3( $cmd, \undef, \$output, \$output );
        }
        catch {
            $output .= "Couldn't run @$cmd: $_";
            return;
        };

        return ( 0, $output )
            unless $success;
    }

    return 1;
}

sub _run_tests {
    my $output = q{};
    my $error  = q{};

    my $stderr = sub {
        my $line = shift;

        $output .= $line;
        $error  .= $line;
    };

    my $cmd;
    if ( -e 'Build' ) {
        $cmd = [qw( ./Build test )];
    }
    elsif ( -e 'Makefile' ) {
        $cmd = [qw( make test )];
    }
    else {
        return ( 0, "Cannot find a Build or Makefile file in $CWD" );
    }

    my $passed;
    try {
        run3( $cmd, undef, \$output, $stderr );
        if ( $? == 0 ) {
            $passed = $output eq q{}
                || $output =~ /Result: (?:PASS|NOTESTS)|No tests defined/;
        }
    }
    catch {
        $output .= "Couldn't run @$cmd: $_";
        $error  .= "Couldn't run @$cmd: $_";
    };

    return ( $passed, $output, $error );
}

{
    my $LOADED_CPAN = 0;

    sub _load_cpan {
        ## no critic (TestingAndDebugging::ProhibitNoWarnings)
        no warnings 'once';
        return if $LOADED_CPAN;

        require CPAN;
        require CPAN::Shell;

        ## no critic (InputOutput::RequireBriefOpen)
        open my $fh, '>', File::Spec->devnull;

        {
            no warnings 'redefine';
            *CPAN::Shell::report_fh = sub {$fh};
        }

        ## no critic (Variables::ProhibitPackageVars)
        $CPAN::Be_Silent = 1;

        CPAN::HandleConfig->load;
        CPAN::Shell::setup_output();
        CPAN::Index->reload('force');

        $CPAN::Config->{test_report} = 0;
        $CPAN::Config->{mbuildpl_arg} .= ' --quiet';
        $CPAN::Config->{prerequisites_policy} = 'follow';
        $CPAN::Config->{make_install_make_command} =~ s/^sudo //;
        $CPAN::Config->{mbuild_install_build_command} =~ s/^sudo //;
        $CPAN::Config->{make_install_arg} =~ s/UNINST=1//;
        $CPAN::Config->{mbuild_install_arg} =~ s/--uninst\s+1//;

        if ( $ENV{PERL_TEST_DM_CPAN_VERBOSE} ) {
            $fh = io_from_write_cb( sub { $Test->diag( $_[0] ) } );
        }

        $LOADED_CPAN = 1;

        return;
    }
}

1;

# ABSTRACT: Test all modules which depend on your module

__END__