File Coverage

blib/lib/Module/CPANTS/Kwalitee/Prereq.pm

Criterion	Covered	Total	%
statement	62	180	34.4
branch	10	90	11.1
condition	10	66	15.1
subroutine	18	20	90.0
pod	3	3	100.0
total	103	359	28.6

package Module::CPANTS::Kwalitee::Prereq;
use warnings;
use strict;
use File::Spec::Functions qw(catfile);
use Text::Balanced qw/extract_bracketed/;

our $VERSION = '1.02';
$VERSION =~ s/_//; ## no critic

sub order { 100 }

##################################################################
# Analyse
##################################################################

sub analyse {
    my $class = shift;
    my $me = shift;

    $class->_from_meta($me) or
    $class->_from_cpanfile($me) or
    $class->_from_build_pl($me) or
    $class->_from_makefile_pl($me) or
    $class->_from_dist_ini($me);
}

sub _flatten_and_sort {
    my $res = shift;
    [sort {$a->{requires} cmp $b->{requires} or $a->{type} cmp $b->{type}} map {@$_} values %$res];
}

sub _from_meta {
    my ($class, $me) = @_;
    my $meta = $me->d->{meta_yml}; # $me->d->{meta_json} || $me->d->{meta_yml};
    return unless $meta && ref $meta eq ref {};

    my $spec = $meta->{'meta-spec'};
    my %res;
    if ($spec && ref $spec eq ref {} && ($spec->{version} || 0) =~ /^(\d+)/ && $1 >= 2) {
        # meta spec ver2
        my $prereqs = $meta->{prereqs};

        %res = $class->_handle_prereqs_v2($meta->{prereqs});
    } else {
        # meta spec ver1
        my %map = (
            requires       => 'is_prereq',
            build_requires => 'is_build_prereq',
            recommends     => 'is_optional_prereq',
        );
        for my $rel (qw/requires recommends build_requires configure_requires conflicts/) {
            if ($meta->{$rel} && ref $meta->{$rel} eq ref {}) {
                my $prereqs_r = $meta->{$rel};
                next unless $prereqs_r && ref $prereqs_r eq ref {};
                for my $module (keys %$prereqs_r) {
                    my $type = $rel =~ /_/ ? $rel : "runtime_$rel";
                    push @{$res{$module} ||= []}, {
                        requires => $module,
                        version => $prereqs_r->{$module},
                        type => $type,
                        ($map{$rel} ? ($map{$rel} => 1) : ()),
                    };
                }
            }
        }

        # TODO: optional_features handling
    }

    return unless %res;
    $me->d->{prereq} = _flatten_and_sort(\%res);
    $me->d->{got_prereq_from} = 'META.yml';
}

sub _from_cpanfile {
    my ($class, $me) = @_;

    my $cpanfile = catfile($me->distdir, "cpanfile");
    return unless -f $cpanfile;
    eval { require Module::CPANfile; 1 };
    return if $@;
    my $prereqs = Module::CPANfile->load($cpanfile)->prereqs->as_string_hash;
    my %res = $class->_handle_prereqs_v2($prereqs);
    return unless %res;

    $me->d->{prereq} = _flatten_and_sort(\%res);
    $me->d->{got_prereq_from} = 'cpanfile';
}

sub _from_build_pl {
    my ($class, $me) = @_;

    my $build_pl_file = catfile($me->distdir, "Build.PL");
    return unless -f $build_pl_file;

    my $build_pl = do { local $/; open my $fh, '<', $build_pl_file; <$fh> };
    return unless $build_pl;

    my %map = (
        requires       => 'is_prereq',
        build_requires => 'is_build_prereq',
        test_requires  => 'is_build_prereq',
        recommends     => 'is_optional_prereq',
    );
    my %res;
    # TODO: auto_features
    while($build_pl =~ s/^.*?((?:(?:configure|build|test)_)?requires|recommends|conflicts)\s*=>\s*\{/{/s) {
        my $rel = $1;
        my ($block, $left) = extract_bracketed($build_pl, '{}');
        last unless $block;

        my $hashref = do { no strict; no warnings; eval $block }; ## no critic
        if ($hashref && ref $hashref eq ref {}) {
            for my $module (keys %$hashref) {
                my $type = $rel =~ /_/ ? $rel : "runtime_$rel";
                my ($version) = ($hashref->{$module} || 0) =~ /^([0-9.]+)/;
                push @{$res{$module} ||= []}, {
                    requires => $module,
                    version => $version,
                    type => $type,
                    ($map{$rel} ? ($map{$rel} => 1) : ()),
                };
            }
        }

        $build_pl = $left;
    }
    $me->d->{prereq} = _flatten_and_sort(\%res);
    $me->d->{got_prereq_from} = 'Build.PL';
}

sub _from_makefile_pl {
    my ($class, $me) = @_;

    my $distdir = $me->distdir;
    my %map = (
        PREREQ_PM      => 'is_prereq',
        BUILD_REQUIRES => 'is_build_prereq',
        TEST_REQUIRES  => 'is_build_prereq',
    );

    # There may be multiple Makefile.PLs in a distribution
    my %res;
    for my $file (@{$me->d->{files_array} || []}) {
        next unless $file =~ /Makefile\.PL$/;
        my $makefile_pl_file = catfile($distdir, $file);
        next unless -f $makefile_pl_file;

        my $makefile_pl = do { local $/; open my $fh, '<', $makefile_pl_file; <$fh> };
        next unless $makefile_pl;

        if ($makefile_pl =~ /use\s+inc::Module::Install/) {
            # Module::Install

            # TODO
            while($makefile_pl =~ s/(?:^|;).+?((?:(?:configure|build|test)_)?requires|recommends)\s*([^;]+);//s) {
                my ($rel, $tuple_text) = ($1, $2);
                my @tuples = do { no strict; no warnings; eval $tuple_text }; ## no critic
                my $type = $rel =~ /_/ ? $rel : "runtime_$rel";
                while(@tuples) {
                    my $module = shift @tuples or last;
                    my $version = shift @tuples || 0;
                        push @{$res{$module} ||= []}, {
                        requires => $module,
                        version => $version,
                        type => $type,
                        ($map{$rel} ? ($map{$rel} => 1) : ()),
                    };
                }
            }
        } else {
            # EUMM
            while($makefile_pl =~ s/^.*?((?:BUILD|TEST)_REQUIRES|PREREQ_PM)\s*=>\s*\{/{/s) {
                my $rel = $1;
                my ($block, $left) = extract_bracketed($makefile_pl, '{}');
                last unless $block;

                my $hashref = do { no strict; no warnings; eval $block }; ## no critic
                if ($hashref && ref $hashref eq ref {}) {
                    for my $module (keys %$hashref) {
                        my $type = $rel eq 'PREREQ_PM' ? "runtime_requires" : lc $rel;
                        push @{$res{$module} ||= []}, {
                            requires => $module,
                            version => $hashref->{$module},
                            type => $type,
                            ($map{$rel} ? ($map{$rel} => 1) : ()),
                        };
                    }
                }
                $makefile_pl = $left;
            }
        }
    }
    $me->d->{prereq} = _flatten_and_sort(\%res);
    $me->d->{got_prereq_from} = 'Makefile.PL';
}

# for META spec v2 and cpanfile
sub _handle_prereqs_v2 {
    my ($class, $prereqs) = @_;

    return unless $prereqs && ref $prereqs eq ref {};

    # XXX: this mapping is for backward compat only
    my %map = (
        runtime_requires   => 'is_prereq',
        build_requires     => 'is_build_prereq',
        test_requires      => 'is_build_prereq',
        runtime_recommends => 'is_optional_prereq',
        build_recommends   => 'is_optional_prereq',
        test_recommends    => 'is_optional_prereq',
        runtime_suggests   => 'is_optional_prereq',
        build_suggests     => 'is_optional_prereq',
        test_suggests      => 'is_optional_prereq',
    );

    my %res;
    for my $phase (keys %$prereqs) {
        my $prereqs_p = $prereqs->{$phase};
        next unless $prereqs_p && ref $prereqs_p eq ref {};
        for my $rel (keys %$prereqs_p) {
            my $prereqs_r = $prereqs_p->{$rel};
            next unless $prereqs_r && ref $prereqs_r eq ref {};
            for my $module (keys %$prereqs_r) {
                my $type = join '_', $phase, $rel;
                push @{$res{$module} ||= []}, {
                    requires => $module,
                    version => $prereqs_r->{$module},
                    type => $type,
                    ($map{$type} ? ($map{$type} => 1) : ()),
                };
            }
        }
    }
    %res;
}

sub _from_dist_ini {
    my ($class, $me) = @_;

    my $inifile = catfile($me->distdir, "dist.ini");
    return unless -f $inifile;

    eval { require Config::INI::Reader } or return;

    my $config = Config::INI::Reader->read_file($inifile);
    return unless $config && ref $config eq ref {};

    my %map = (
        runtime_requires   => 'is_prereq',
        build_requires     => 'is_build_prereq',
        test_requires      => 'is_build_prereq',
        runtime_recommends => 'is_optional_prereq',
        build_recommends   => 'is_optional_prereq',
        test_recommends    => 'is_optional_prereq',
        runtime_suggests   => 'is_optional_prereq',
        build_suggests     => 'is_optional_prereq',
        test_suggests      => 'is_optional_prereq',
    );
    my %res;
    for my $key (keys %$config) {
        next unless $key =~ /^Prereqs\b/;
        my ($phase, $rel) = qw(runtime requires);
        (undef, my $type) = split /\s*\/\s*/, $key, 2;
        if ($type) {
            if ($type =~ s/^(Configure|Build|Test|Runtime)//) {
                $phase = lc $1;
            }
            if ($type =~ s/^(Requires|Recommends|Suggests)//) {
                $rel = lc $1;
            }
        }
        my $conf = $config->{$key};
        next unless $conf && ref $conf eq ref {};
        if ($conf->{-phase}) {
            $phase = delete $conf->{-phase};
        }
        if ($conf->{-relationship}) {
            $rel = delete $conf->{-relationship};
        }
        for my $module (keys %$conf) {
            $type = join '_', $phase, $rel;
            push @{$res{$module} ||= []}, {
                requires => $module,
                version => $conf->{$module},
                type => $type,
                ($map{$type} ? ($map{$type} => 1) : ()),
            };
        }
    }
    $me->d->{prereq} = _flatten_and_sort(\%res);
    $me->d->{got_prereq_from} = 'dist.ini';
}

##################################################################
# Kwalitee Indicators
##################################################################

sub kwalitee_indicators{
    # NOTE: The metrics in this module have moved to
    # Module::CPANTS::SiteKwalitee because these require databases.

    return [];
}


q{Favourite record of the moment:
  Fat Freddys Drop: Based on a true story};

__END__