<commit_before>package Test::DependentModules;

use strict;
use warnings;
use autodie;

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

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

our @EXPORT_OK = qw( test_all_dependents test_module test_modules );

$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;

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 $result = MetaCPAN::API->new->post(
        "/search/reverse_dependencies/$module",
        {
            query => { match_all => {} },
            size  => 5000,
            filter => {
                and => [
                    {
                        term => { 'release.status' => 'latest'},
                    },
                    {
                        term => { 'authorized' => 'true' },
                    },
                ],
            },
        },
    );

    # metacpan requires scrolled queries for requests returning more than 5000
    # results, i don't think this will actually be a problem
    if ($result->{hits}{total} > 5000) {
        $Test->diag("Too many reverse dependencies ($result->{hits}{total}), "
                  . "limiting to 5000");
    }

    my @deps = map { $_->{_source}{distribution} } @{ $result->{hits}{hits} };

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

    return grep { $_ !~ /^(?:Task|Bundle)/ } grep { $allow->($_) } @deps;
}

sub test_modules {
    _load_cpan();
    _make_logs();

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

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

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

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}
                    {qw( name passed summary output stderr skipped )} );
        }
    );

    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) {
        if ($pm) {
            $pm->finish(
                0, {
                    name    => $name,
                    skipped => "Could not find $name on CPAN",
                }
            );
        }
        else {
            local $Test::Builder::Level = $Test::Builder::Level + 1;
            _test_report(
                $name, undef, undef, undef, undef,
                "Could not find $name on CPAN"
            );
        }

        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;
        if ($pm) {
            $pm->finish(
                0, {
                    name    => $name,
                    skipped => $msg,
                }
            );
        }
        else {
            local $Test::Builder::Level = $Test::Builder::Level + 1;
            _test_report( $name, undef, undef, undef, undef, $msg );
        }

        return;
    };
    return unless $success;

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

    $stderr = q{}
        # 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
        if $stderr =~ /\A\# Testing [\w:]+ [^\n]+\Z/;

    my $status = $passed && $stderr ? 'WARN' : $passed ? 'PASS' : 'FAIL';

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

    if ($pm) {
        $pm->finish(
            0, {
                name    => $name,
                passed  => $passed,
                summary => $summary,
                output  => $output,
                stderr  => $stderr,
            }
        );
    }
    else {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        _test_report( $name, $passed, $summary, $output, $stderr );
    }
}

sub _test_report {
    my $name    = shift;
    my $passed  = shift;
    my $summary = shift;
    my $output  = shift;
    my $stderr  = shift;
    my $skipped = shift;

    if ($skipped) {
        _status_log("UNKNOWN : $name ($skipped)\n");

        $Test->skip($skipped);

        return;
    }

    _status_log("$summary\n");
    _error_log("$summary\n");

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

    if ( $passed && !$stderr ) {
        _error_log("\n");
    }
    else {
        _error_log( q{-} x 50 );
        _error_log("\n");
        _error_log("$output\n");
    }
}

{
    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 );

    die "Cannot resolve $name to a single CPAN module"
        if @mods > 1;

    return unless @mods;

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

    die "Cannot resolve $name to its associated CPAN distribution"
        unless $dist;

    $dist->get();

    return $dist;
}<commit_msg>this should just be a skip too<commit_after>package Test::DependentModules;

use strict;
use warnings;
use autodie;

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

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

our @EXPORT_OK = qw( test_all_dependents test_module test_modules );

$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;

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 $result = MetaCPAN::API->new->post(
        "/search/reverse_dependencies/$module",
        {
            query => { match_all => {} },
            size  => 5000,
            filter => {
                and => [
                    {
                        term => { 'release.status' => 'latest'},
                    },
                    {
                        term => { 'authorized' => 'true' },
                    },
                ],
            },
        },
    );

    # metacpan requires scrolled queries for requests returning more than 5000
    # results, i don't think this will actually be a problem
    if ($result->{hits}{total} > 5000) {
        $Test->diag("Too many reverse dependencies ($result->{hits}{total}), "
                  . "limiting to 5000");
    }

    my @deps = map { $_->{_source}{distribution} } @{ $result->{hits}{hits} };

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

    return grep { $_ !~ /^(?:Task|Bundle)/ } grep { $allow->($_) } @deps;
}

sub test_modules {
    _load_cpan();
    _make_logs();

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

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

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

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}
                    {qw( name passed summary output stderr skipped )} );
        }
    );

    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) {
        if ($pm) {
            $pm->finish(
                0, {
                    name    => $name,
                    skipped => "Could not find $name on CPAN",
                }
            );
        }
        else {
            local $Test::Builder::Level = $Test::Builder::Level + 1;
            _test_report(
                $name, undef, undef, undef, undef,
                "Could not find $name on CPAN"
            );
        }

        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;
        if ($pm) {
            $pm->finish(
                0, {
                    name    => $name,
                    skipped => $msg,
                }
            );
        }
        else {
            local $Test::Builder::Level = $Test::Builder::Level + 1;
            _test_report( $name, undef, undef, undef, undef, $msg );
        }

        return;
    };
    return unless $success;

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

    $stderr = q{}
        # 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
        if $stderr =~ /\A\# Testing [\w:]+ [^\n]+\Z/;

    my $status = $passed && $stderr ? 'WARN' : $passed ? 'PASS' : 'FAIL';

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

    if ($pm) {
        $pm->finish(
            0, {
                name    => $name,
                passed  => $passed,
                summary => $summary,
                output  => $output,
                stderr  => $stderr,
            }
        );
    }
    else {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        _test_report( $name, $passed, $summary, $output, $stderr );
    }
}

sub _test_report {
    my $name    = shift;
    my $passed  = shift;
    my $summary = shift;
    my $output  = shift;
    my $stderr  = shift;
    my $skipped = shift;

    if ($skipped) {
        _status_log("UNKNOWN : $name ($skipped)\n");

        $Test->skip($skipped);

        return;
    }

    _status_log("$summary\n");
    _error_log("$summary\n");

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

    if ( $passed && !$stderr ) {
        _error_log("\n");
    }
    else {
        _error_log( q{-} x 50 );
        _error_log("\n");
        _error_log("$output\n");
    }
}

{
    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;
}
{'fraction_non_alphanumeric': 0.15612166324435317, 'fraction_numerical': 0.006930184804928132, 'mean_word_length': 1.6482582837723025, 'pattern_counts': {'":': 0, '<': 3, '<?xml version=': 0, '>': 128, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2106732', 'n_tokens_mistral': 5344, 'n_tokens_neox': 4989, 'n_words': 1169}