view release on metacpan or  search on metacpan

lib/App/LintPrereqs.pm  view on Meta::CPAN

given some weird code.

`nqlite` means <pm:Perl::PrereqScanner::NotQuiteLite> which is faster than
`regular` but not as fast as `lite`.

MARKDOWN
        },
        lite => {
            schema => ['bool*'],
            default => 0,
            summary => 'Use Perl::PrereqScanner::Lite instead of Perl::PrereqScanner',
            "summary.alt.bool.not" =>
                'Use Perl::PrereqScanner instead of Perl::PrereqScanner::Lite',
            description => <<'MARKDOWN',

This option is deprecated and has been replaced by `scanner`.

Lite is faster but it might still miss detecting some modules.

MARKDOWN
            tags => ['deprecated', 'hidden'],
        },
        core_prereqs => {
            schema => ['bool*'],
            default => 1,
            summary => 'Whether or not prereqs to core modules are allowed',
            description => <<'MARKDOWN',

If set to 0 (the default), will complain if there are prerequisites to core
modules. If set to 1, prerequisites to core modules are required just like other
modules.

MARKDOWN
        },
        fix => {
            schema => 'bool',
            summary => 'Attempt to automatically fix the errors',
            cmdline_aliases => {F=>{}},
            description => <<'MARKDOWN',

`lint-prereqs` can attempt to automatically fix the errors by
adding/removing/moving prereqs in `dist.ini`. Not all errors can be
automatically fixed. When modifying `dist.ini`, a backup in `dist.ini~` will be
created.

MARKDOWN
        },
    },
};
sub lint_prereqs {
    my %args = @_;

    (-f "dist.ini")
        or return [412, "No dist.ini found. ".
                       "Are you in the right dir (dist top-level)? ".
                           "Is your dist managed by Dist::Zilla?"];

    my $ct = do {
        open my($fh), "<", "dist.ini" or die "Can't open dist.ini: $!";
        local $/;
        binmode $fh, ":encoding(utf8)";
        scalar <$fh>;
    };
    return [200, "Not run (no-lint-prereqs)"] if $ct =~ /^;!no[_-]lint[_-]prereqs$/m;

    my @errs;

    my $ciod = Config::IOD->new(
        ignore_unknown_directive => 1,
    );

    my $cfg = $ciod->read_string($ct);

    my %mods_from_ini;
    my %assume_used;
    my %assume_provided;
    for my $section ($cfg->list_sections) {
        $section =~ m!^(
                          osprereqs \s*/\s* .+ |
                          osprereqs(::\w+)+ |
                          prereqs (?: \s*/\s* (?<prereqs_phase_rel>\w+))? |
                          extras \s*/\s* lint[_-]prereqs \s*/\s* (assume-(?:provided|used))
                      )$!ix or next;
        #$log->errorf("TMP: section=%s, %%+=%s", $section, {%+});

        my ($phase, $rel);
        if (my $pr = $+{prereqs_phase_rel}) {
            if ($pr =~ /^(develop|configure|build|test|runtime|x_\w+)(requires|recommends|suggests|x_\w+)$/i) {
                $phase = ucfirst(lc($1));
                $rel = ucfirst(lc($2));
            } else {
                return [400, "Invalid section '$section' (invalid phase/rel $pr)"];
            }
        } else {
            $phase = "Runtime";
            $rel = "Requires";
        }

        my %params;
        for my $param ($cfg->list_keys($section)) {
            my $v = $cfg->get_value($section, $param);
            if ($param =~ /^-phase$/) {
                $phase = ucfirst(lc($v));
                next;
            } elsif ($param =~ /^-(relationship|type)$/) {
                $rel = ucfirst(lc($v));
                next;
            }
            $params{$param} = $v;
        }
        #$log->tracef("phase=%s, rel=%s", $phase, $rel);

        for my $param (sort keys %params) {
            my $v = $params{$param};
            if (ref($v) eq 'ARRAY') {
                return [412, "Multiple '$param' prereq lines specified in dist.ini"];
            }
            my $dir = $cfg->get_directive_before_key($section, $param);
            my $dir_s = $dir ? join(" ", @$dir) : "";
            log_trace("section=%s, v=%s, param=%s, directive=%s", $section, $param, $v, $dir_s);

lib/App/LintPrereqs.pm  view on Meta::CPAN

                    }
                }
                $v = $versions->{$mod}
                    if $versions->{$mod} && version_gt($versions->{$mod}, $v);
                push @errs, {
                    module  => $mod,
                    req_v   => $v,
                    is_core => $is_core,
                    error   => "Used but not listed in dist.ini",
                    remedy  => "Put '$mod=$v' in dist.ini (e.g. in [Prereqs/${phase}Requires])",
                    remedy_cmds => [
                        ["pdrutil", "add-prereq", $mod, $v, "--phase", lc($phase)],
                    ],
                };
            }
        }
    } # END check modules from scanned

    # check minimum versions specified in [versions] in our config
    {
        last unless $versions;
        log_trace("Checking minimum versions ...");
        for my $mod (keys %{$mods_from_ini{Any}}) {
            next if $mod eq 'perl';
            my $v = $mods_from_ini{Any}{$mod};
            my $is_core = Module::CoreList::More->is_still_core($mod, $v, $perlv);
            my $min_v = $versions->{$mod};
            if (defined($min_v) && version_gt($min_v, $v)) {
                push @errs, {
                    module  => $mod,
                    req_v   => $v,
                    is_core => $is_core,
                    error   => "Less than specified minimum version ($min_v) in lint-prereqs.conf",
                    remedy  => "Increase version to $min_v",
                    remedy_cmds => [
                        ["pdrutil", "inc-prereq-version-to", $mod, $min_v],
                    ],
                };
            }
        }
    } # END check minimum versions

    return [200, "OK", []] unless @errs;

    @errs = sort {prereq_ala_perlancar($a->{module}, $b->{module})} @errs;

    my $resmeta = {};
    $resmeta->{'table.fields'} = [qw/module req_v is_core error remedy/];

    if ($args{fix}) {
        # there is an unfixable error
        if (grep {!$_->{remedy_cmds}} @errs) {
            for my $e (@errs) {
                $e->{remedy} = " (CAN'T FIX AUTOMATICALLY) $e->{remedy}" unless $e->{remedy_cmds};
            }
            $resmeta->{'cmdline.exit_code'} = 112;
        } else {
            # create dist.ini~ first
            if (-f "dist.ini~") { unlink "dist.ini~" or return [500, "Can't unlink dist.ini~: $!"] }
            sysopen my($fh), "dist.ini~", O_WRONLY|O_CREAT|O_EXCL or return [500, "Can't create dist.ini~: $!"];
            binmode $fh, ":encoding(utf8)"; print $fh $ct; close $fh or return [500, "Can't write to dist.ini~: $!"];

            # run the commands
          FIX:
            {
                # add sort-prereqs at the end
                push @{ $errs[-1]{remedy_cmds} }, ["pdrutil", "sort-prereqs"];

              ERR:
                for my $e (@errs) {
                    for my $cmd (@{ $e->{remedy_cmds} }) {
                        system @$cmd;
                        if ($?) {
                            $e->{remedy} = "(FIX FAILED: ".explain_child_error().") $e->{remedy}";
                            $resmeta->{'cmdline.exit_code'} = 1;
                            # restore dist.ini from backup
                            rename "dist.ini~", "dist.ini";
                            last FIX;
                        }
                    }
                }
                for my $e (@errs) {
                    $e->{remedy} = "(DONE) $e->{remedy}";
                }
                $resmeta->{'cmdline.exit_code'} = 0;
                # remove dist.ini~
                #unlink "dist.ini~";
            }
        }
        for my $e (@errs) { delete $e->{$_} for qw/remedy_cmds/ }
        return [200, "OK", \@errs, $resmeta];
    } else {
        for my $e (@errs) { delete $e->{$_} for qw/remedy_cmds/ }
        $resmeta->{'cmdline.exit_code'} = 200;
        return [200, "OK", \@errs, $resmeta];
    }
}

1;
# ABSTRACT: Check extraneous/missing/incorrect prerequisites in dist.ini

__END__

=pod

=encoding UTF-8

=head1 NAME

App::LintPrereqs - Check extraneous/missing/incorrect prerequisites in dist.ini

=head1 VERSION

This document describes version 0.544 of App::LintPrereqs (from Perl distribution App-LintPrereqs), released on 2024-12-21.

=head1 SYNOPSIS

 # Use via lint-prereqs CLI script

=head1 FUNCTIONS