File Coverage

bin/report-prereqs

Criterion	Covered	Total	%
statement	136	137	99.2
branch	39	42	92.8
condition	26	30	86.6
subroutine	14	14	100.0
pod			n/a
total	215	223	96.4

#!perl

use 5.006;
use strict;
use warnings;

our $VERSION = '0.008';

package App::ReportPrereqs;

use CPAN::Meta;
use ExtUtils::MakeMaker ();
use File::Basename qw(fileparse);
use Getopt::Long qw(GetOptions);
use HTTP::Tiny 0.014 ();
use List::Util qw(max);
use Module::CPANfile ();
use Module::Path qw(module_path);
use version 0.77 ();

if ( !caller ) {
    my $rc = _main();
    exit 0 if !defined $rc;
    exit 2 if $rc == 2;
    exit 1;
}

sub _main {
    my $cpanfile;
    my $meta;
    my $with_develop = 0;
    my @features;
    my $getoptions_ok = GetOptions(
        'cpanfile:s'      => \$cpanfile,
        'meta:s'          => \$meta,
        'with-develop'    => \$with_develop,
        'with-feature=s@' => \@features,
    );

    my $url = shift @ARGV;

    if (
        # Wrong options used
        !$getoptions_ok

        # --cpanfile and --meta cannot be used together
        || ( defined $cpanfile && defined $meta )

        # --cpanfile or --meta cannot be used together with a URL
        || ( ( defined $cpanfile || defined $meta ) && defined $url )

        # Only at most one URL can be specified
        || (@ARGV)
      )
    {
        _usage();
        return 2;
    }

    my $prereqs;
    my $source;
    if ( defined $meta ) {
        if ( $meta eq q{} ) {
            $meta = 'META.json';
        }
        $source = $meta;

        local $@;    ## no critic (Variables::RequireInitializationForLocalVars)
        if ( !eval { $prereqs = CPAN::Meta->load_file($meta)->effective_prereqs( \@features ); 1 } ) {
            my $error = $@;
            print {*STDERR} "Cannot read meta file '$meta': $error\n";
            return 1;
        }
    }
    else {
        if ( defined $url ) {
            $source = $url;

            my $res = HTTP::Tiny->new->get($source);
            if ( !$res->{success} ) {
                print {*STDERR} $res->{content};
                return 1;
            }

            $cpanfile = \$res->{content};
        }
        else {
            if ( !defined $cpanfile || $cpanfile eq q{} ) {
                $cpanfile = 'cpanfile';
            }
            $source = $cpanfile;
        }

        local $@;    ## no critic (Variables::RequireInitializationForLocalVars)
        if ( !eval { $prereqs = Module::CPANfile->load($cpanfile)->prereqs_with(@features); 1; } ) {
            my $error = $@;
            print {*STDERR} "Cannot read cpanfile file '$cpanfile': $error\n";
            return 1;
        }
    }

    # ---
    my @full_reports;
    my @dep_errors;

  PHASE:
    for my $phase (qw(configure build test runtime develop)) {
        next PHASE if ( $phase eq 'develop' ) and ( !$with_develop );

      TYPE:
        for my $type (qw(requires recommends suggests conflicts)) {
            my $req_ref = $prereqs->requirements_for( $phase, $type )->as_string_hash;
            my @modules = grep { $_ ne 'perl' } keys %{$req_ref};
            next TYPE if !@modules;

            my $title   = "\u$phase \u$type";
            my @reports = ( [qw(Module Want Have)] );

          MODULE:
            for my $module ( sort @modules ) {
                my $want = $req_ref->{$module};
                if ( !defined $want ) {
                    $want = 'undef';
                }
                elsif ( $want eq '0' ) {
                    $want = 'any';
                }

                my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required";

                my $mod_path = module_path($module);

                if ( defined $mod_path ) {
                    my $have = MM->parse_version($mod_path);    ## no critic (Modules::RequireExplicitInclusion)

                    # This validation was added in EUMM 7.47_01 in ExtUtils::MM_Unix
                    # We use the same validation to make the file testable - otherwise the
                    # result depends on the version of EUMM used.
                    if (   ( !defined $have )
                        or ( $have !~ m{ ^ v? [0-9_\.\-]+ $ }xsm )
                        or ( !eval { version->parse($have) } ) )
                    {
                        $have = 'undef';
                    }

                    push @reports, [ $module, $want, $have ];

                    next MODULE if $type ne 'requires';

                    if ( $have eq 'undef' ) {
                        push @dep_errors, "$module version unknown ($req_string)";
                        next MODULE;
                    }

                    if ( !$prereqs->requirements_for( $phase, $type )->accepts_module( $module => $have ) ) {
                        push @dep_errors, "$module version '$have' is not in required range '$want'";
                        next MODULE;
                    }

                    next MODULE;
                }

                push @reports, [ $module, $want, 'missing' ];

                next MODULE if $type ne 'requires';

                push @dep_errors, "$module is not installed ($req_string)";
            }

            push @full_reports, "=== $title ===\n\n";

            my $ml = max( map { length $_->[0] } @reports );
            my $wl = max( map { length $_->[1] } @reports );
            my $hl = max( map { length $_->[2] } @reports );

            splice @reports, 1, 0, [ q{-} x $ml, q{-} x $wl, q{-} x $hl ];
            push @full_reports, map { sprintf "    %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2] } @reports;

            push @full_reports, "\n";
        }
    }

    if (@full_reports) {
        print "Versions for all modules listed in $source:\n\n", @full_reports;
    }

    if (@dep_errors) {
        print "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n\n";
        print "The following REQUIRED prerequisites were not satisfied:\n\n";

        for my $error (@dep_errors) {
            print $error, "\n";
        }
    }

    return;
}

sub _usage {
    my $basename = fileparse($0);

    print {*STDERR} "usage: $basename [--with-develop] [--with-feature ] [URL]\n";
    print {*STDERR} "       $basename [--with-develop] [--with-feature ] [--cpanfile []]\n";
    print {*STDERR} "       $basename [--with-develop] [--with-feature ] [--meta [|]]\n";

    return;
}

1;

__END__