File Coverage

blib/lib/Perl/Lint.pm

Criterion	Covered	Total	%
statement	94	100	94.0
branch	25	30	83.3
condition	5	9	55.5
subroutine	10	11	90.9
pod	1	3	33.3
total	135	153	88.2

package Perl::Lint;
use 5.010001;
use strict;
use warnings;
use Carp ();
use Compiler::Lexer;
use Module::Pluggable;
use Module::Load;

our $VERSION = "0.24";

sub new {
    my ($class, $args) = @_;

    my @ignores;

    if (my $ignores = $args->{ignore}) {
        if (ref $ignores ne 'ARRAY') {
            Carp::croak "`ignore` must be array reference";
        }

        push @ignores, map {"Perl::Lint::Policy::$_"} @$ignores;
    }

    if (my $filters = $args->{filter}) {
        if (ref $filters ne 'ARRAY') {
            Carp::croak "`filter` must be array reference";
        }

        for my $filter (@$filters) {
            my $filter_package = "Perl::Lint::Filter::$filter";
            load $filter_package;

            push @ignores, map {"Perl::Lint::Policy::$_"} @{$filter_package->filter};
        }
    }

    Module::Pluggable->import(
        search_path => 'Perl::Lint::Policy',
        require     => 1,
        inner       => 0,
        except      => [@ignores],
    );
    my @site_policies = plugins(); # Exported by Module::Pluggable

    # TODO add mechanism to add extend policies

    bless {
        args => $args,
        site_policies => \@site_policies,
    }, $class;
}

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

    my @files = ($files); # when scalar value
    if (my $ref = ref $files) {
        if ($ref ne 'ARRAY') {
            Carp::croak("Argument of files expects scalar value or array reference");
        }
        @files = @$files;
    }

    my @violations;
    for my $file (@files) {
        open my $fh, '<', $file or die "Cannnot open $file: $!";
        my $src = do { local $/; <$fh> };

        push @violations, @{$self->_lint($src, $file)};
    }

    return \@violations;
}

sub lint_string {
    my ($self, $src) = @_;

    return $self->_lint($src);
}

sub _lint {
    my ($self, $src, $file) = @_;

    if (!defined $src || $src eq '') {
        return [];
    }

    my $args = $self->{args};

    my $lexer = Compiler::Lexer->new($file);
    my $tokens = $lexer->tokenize($src);

    # list `no lint` lines
    # TODO improve performance
    my %no_lint_lines = ();
    my %used_no_lint_lines = ();
    my $line_num = 1;
    for my $line (split /\r?\n/, $src) {
        $line =~ s/"(?:[^"]*?#[^"]*?)*"//g;
        $line =~ s/'(?:[^']*?#[^']*?)*'//g;
        $line =~ s/\[(?:[^\[]*?#[^\]]*?)*\]//g;
        if ($line =~ /(#.+)?##\s*no\slint(?:\s+(?:qw)?([(][^)]*[)]|"[^"]*"|'[^']*'))?/) {
            next if $1; # Already commented out at before

            my $annotations = {};
            if ($2) {
                my $annotation = substr $2, 1, -1;
                $annotations = {map {$_ => 1} grep {$_} split /[, ]/, $annotation};
            }
            $no_lint_lines{$line_num} = $annotations;
        }
        $line_num++;
    }

    my $prohibit_useless_no_lint_policy;

    my @violations;
    for my $policy (@{$self->{site_policies}}) {
        if ($policy eq 'Perl::Lint::Policy::Miscellanea::ProhibitUselessNoLint') {
            $prohibit_useless_no_lint_policy = $policy;
            next;
        }

        if ($policy eq 'Perl::Lint::Policy::Miscellanea::ProhibitUnrestrictedNoLint') {
            push @violations, @{$policy->evaluate($file, $tokens, $src, $args, \%no_lint_lines)};
            next;
        }


        for my $violation (@{$policy->evaluate($file, $tokens, $src, $args)}) {
            my $violation_line = $violation->{line};
            my $no_lint = $no_lint_lines{$violation_line};
            if (!$no_lint || (keys %$no_lint > 0 && !$no_lint->{(split /::/, $violation->{policy})[-1]})) {
                push @violations, $violation;
            }
            $used_no_lint_lines{$violation_line} = 1;
        }
    }

    if ($prohibit_useless_no_lint_policy) {
        push @violations,
            @{$prohibit_useless_no_lint_policy->evaluate($file, \%no_lint_lines, \%used_no_lint_lines)};
    }

    return \@violations;
}

1;

__END__