File Coverage

lib/App/CPANTS/Lint.pm

Criterion	Covered	Total	%
statement	12	152	7.8
branch	0	84	0.0
condition	0	42	0.0
subroutine	4	16	25.0
pod	8	8	100.0
total	24	302	7.9

package App::CPANTS::Lint;

use strict;
use warnings;
use Carp;
use Module::CPANTS::Analyse;

our $VERSION = '0.04';

sub new {
    my ($class, %opts) = @_;
    $opts{no_capture} = 1 if !defined $opts{no_capture};
    $opts{dump} = 1 if $opts{yaml} || $opts{json};
    bless {opts => \%opts}, $class;
}

sub lint {
    my ($self, $dist) = @_;

    croak "Cannot find $dist" unless -f $dist;

    my $mca = $self->{mca} = Module::CPANTS::Analyse->new({
        dist => $dist,
        opts => $self->{opts},
    });
    my $res = $self->{res} = {dist => $dist};

    {
        if (-f $dist and my $error = $mca->unpack) {
            warn "$dist: $error\n" and last;
        }
        $mca->analyse;
    }
    $mca->calc_kwalitee;

    my $kwl = $mca->d->{kwalitee};
    my %err = %{ $mca->d->{error} || {} };
    my (%fails, %passes);
    for my $ind (@{$mca->mck->get_indicators}) {
        if ($ind->{needs_db}) {
            push @{$res->{ignored} ||= []}, $ind->{name};
            next;
        }
        if ($mca->can('x_opts') && $mca->x_opts->{ignore}{$ind->{name}} && $ind->{ignorable}) {
            push @{$res->{ignored} ||= []}, $ind->{name};
            next;
        }
        next if ($kwl->{$ind->{name}} || 0) > 0;
        my $type = $ind->{is_extra} ? 'extra' :
                   $ind->{is_experimental} ? 'experimental' :
                   'core';
        next if $type eq 'experimental' && !$self->{opts}{experimental};
        my $error = $err{$ind->{name}};
        if ($error && ref $error) {
            $error = $self->_dump($error);
        }
        push @{$fails{$type} ||= []}, {
            name => $ind->{name},
            remedy => $ind->{remedy},
            error => $error,
        };
    }

    $res->{fails} = \%fails;
    $res->{score} = $self->score(1);

    return $res->{ok} = (!$fails{core} and (!$fails{extra} || $self->{opts}{core_only})) ? 1 : 0;
}

sub _dump {
    my ($self, $thingy, $pretty) = @_;
    if ($self->{opts}{yaml} && eval { require CPAN::Meta::YAML }) {
        return CPAN::Meta::YAML::Dump($thingy);
    } elsif ($self->{opts}{json} && eval { require JSON::PP }) {
        my $coder = JSON::PP->new->utf8;
        $coder->pretty if $pretty;
        return $coder->encode($thingy);
    } else {
        require Data::Dumper;
        my $dumper = Data::Dumper->new([$thingy])->Terse(1)->Sortkeys(1);
        $dumper->Indent(0) unless $pretty;
        $dumper->Dump;
    }
}

sub stash  { shift->{mca}->d }
sub result { shift->{res} }

sub score {
    my ($self, $wants_detail) = @_;

    my $mca = $self->{mca};
    my %fails = %{$self->{res}{fails} || {}};
    my $max_core_kw = $mca->mck->available_kwalitee;
    my $max_kw = $mca->mck->total_kwalitee;
    my $total_kw = $max_kw - @{$fails{core} || []} - @{$fails{extra} || []};

    my $score = sprintf "%.2f", 100 * $total_kw/$max_core_kw;

    if ($wants_detail) {
        $score .= "% ($total_kw/$max_core_kw)";
    }
    $score;
}

sub report {
    my $self = shift;

    # shortcut
    if ($self->{opts}{dump}) {
        return $self->_dump($self->stash, 'pretty');
    } elsif ($self->{opts}{colour} && $self->_supports_colour) {
        return $self->_colour;
    }

    my $res = $self->{res} || {};

    my $report =
        "Checked dist: $res->{dist}\n" .
        "Score: $res->{score}\n";

    if ($res->{ignored}) {
        $report .= "Ignored metrics: " . join(', ', @{$res->{ignored}}) . "\n";
    }

    if ($res->{ok}) {
        $report .= "Congratulations for building a 'perfect' distribution!\n";
    }
    for my $type (qw/core extra experimental/) {
        if (my $fails = $res->{fails}{$type}) {
            $report .=
                "\n" .
                "Failed $type Kwalitee metrics and\n" .
                "what you can do to solve them:\n\n";
            for my $fail (@$fails) {
                $report .=
                    "Name: $fail->{name}\n" .
                    "Remedy: $fail->{remedy}\n";
                if ($fail->{error}) {
                    $report .= "Error: $fail->{error}\n";
                }
                $report .= "\n";
            }
        }
    }

    $report;
}

sub _supports_colour {
    my $self = shift;
    eval {
        require Term::ANSIColor;
        require Win32::Console::ANSI if $^O eq 'MSWin32';
        1
    }
}

sub _colour_scheme {
    my $self = shift;
    my %scheme = (
        heading => "bright_white",
        title => "blue",
        fail => "bright_red",
        pass => "bright_green",
        warn => "bright_yellow",
        error => "red",
        summary => "blue",
    );
    if ($^O eq 'MSWin32') {
        $scheme{$_} =~ s/bright_// for keys %scheme;
    }
    \%scheme;
}

sub _colour {
    my ($self) = @_;
    my $scheme = $self->_colour_scheme;
    my $icon = $^O eq 'MSWin32'
        ? {pass => 'o', fail => 'x'}
        : {pass => "\x{2713}", fail => "\x{2717}"};

    my $report = Term::ANSIColor::colored("Distribution: ", "bold $scheme->{heading}")
        . Term::ANSIColor::colored($self->result->{dist}, "bold $scheme->{title}")
        . "\n";

    my %failed;
    for my $arr (values %{$self->result->{fails}}) {
        for my $fail (@$arr) {
            $failed{$fail->{name}} = $fail;
        }
    }

    my $core_fails = 0;
    for my $type (qw/ Core Optional Experimental /) {
        $report .= Term::ANSIColor::colored("\n$type\n", "bold $scheme->{heading}");
        my @inds = $self->{mca}->mck->get_indicators(lc $type);
        my @fails;
        for my $ind (@inds) {
            if ($failed{ $ind->{name} }) {
                push @fails, $ind;
                $core_fails++ if $type eq 'Core';
                $report .= Term::ANSIColor::colored("  $icon->{fail} ", $scheme->{fail}) . $ind->{name};
                $report .= ": " . Term::ANSIColor::colored($failed{ $ind->{name} }{error}, $scheme->{error})
                    if $failed{ $ind->{name} }{error};
            } else {
                $report .= Term::ANSIColor::colored("  $icon->{pass} ", $scheme->{pass}) . $ind->{name};
            }
            $report .= "\n";
        }

        for my $fail (@fails) {
            $report .= "\n"
                . Term::ANSIColor::colored("Name:   ", "bold $scheme->{summary}")
                . Term::ANSIColor::colored("$fail->{name}\n", $scheme->{summary})
                . Term::ANSIColor::colored("Remedy: ", "bold $scheme->{summary}")
                . Term::ANSIColor::colored("$fail->{remedy}\n", $scheme->{summary});
        }
    }

    my $scorecolour = $scheme->{pass};
    $scorecolour = $scheme->{warn} if keys %failed;
    $scorecolour = $scheme->{fail} if $core_fails;

    $report .= "\n"
        . Term::ANSIColor::colored("Score: ", "bold $scheme->{heading}")
        . Term::ANSIColor::colored($self->result->{score}, "bold $scorecolour")
        . "\n";

    $report;
}

sub output_report {
    my $self = shift;
    if ($self->{opts}{save}) {
        my $file = $self->report_file;
        open my $fh, '>:utf8', $file or croak "Cannot write to $file: $!";
        print $fh $self->report;
    } else {
        binmode(STDOUT, ':utf8');
        print $self->report;
    }
}

sub report_file {
    my $self = shift;
    my $dir = $self->{opts}{dir} || '.';
    my $vname = $self->{mca}->d->{vname};
    if (!$vname) {
        require File::Basename;
        $vname = File::Basename::basename($self->{res}{dist});
    }
    my $extension =
        $self->{opts}{yaml} ? '.yml' :
        $self->{opts}{json} ? '.json' :
        $self->{opts}{dump} ? '.dmp' :
        '.txt';

    require File::Spec;
    File::Spec->catfile($dir, "$vname$extension");
}

1;

__END__