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


line stmt bran cond sub pod time code
1             package Perl::Lint;
2 136     136   114067 use 5.010001;
  136         309  
3 136     136   441 use strict;
  136         121  
  136         2043  
4 136     136   365 use warnings;
  136         132  
  136         2402  
5 136     136   370 use Carp ();
  136         122  
  136         1695  
6 136     136   48519 use Compiler::Lexer;
  136         337536  
  136         5699  
7 136     136   57029 use Module::Pluggable;
  136         1095656  
  136         667  
8 136     136   66415 use Module::Load;
  136         103612  
  136         695  
9              
10             our $VERSION = "0.24";
11              
12             sub new {
13 1396     1396 0 8694728 my ($class, $args) = @_;
14              
15 1396         2510 my @ignores;
16              
17 1396 100       6027 if (my $ignores = $args->{ignore}) {
18 3 100       9 if (ref $ignores ne 'ARRAY') {
19 1         157 Carp::croak "`ignore` must be array reference";
20             }
21              
22 2         5 push @ignores, map {"Perl::Lint::Policy::$_"} @$ignores;
  3         9  
23             }
24              
25 1395 100       5192 if (my $filters = $args->{filter}) {
26 3 100       10 if (ref $filters ne 'ARRAY') {
27 1         135 Carp::croak "`filter` must be array reference";
28             }
29              
30 2         6 for my $filter (@$filters) {
31 2         5 my $filter_package = "Perl::Lint::Filter::$filter";
32 2         9 load $filter_package;
33              
34 2         18 push @ignores, map {"Perl::Lint::Policy::$_"} @{$filter_package->filter};
  115         130  
  2         12  
35             }
36             }
37              
38             Module::Pluggable->import(
39 1394         12680 search_path => 'Perl::Lint::Policy',
40             require => 1,
41             inner => 0,
42             except => [@ignores],
43             );
44 1394         113471 my @site_policies = plugins(); # Exported by Module::Pluggable
45              
46             # TODO add mechanism to add extend policies
47              
48 1394         57831279 bless {
49             args => $args,
50             site_policies => \@site_policies,
51             }, $class;
52             }
53              
54             sub lint {
55 2500     2500 1 1768027 my ($self, $files) = @_;
56              
57 2500         5448 my @files = ($files); # when scalar value
58 2500 50       10328 if (my $ref = ref $files) {
59 0 0       0 if ($ref ne 'ARRAY') {
60 0         0 Carp::croak("Argument of files expects scalar value or array reference");
61             }
62 0         0 @files = @$files;
63             }
64              
65 2500         3333 my @violations;
66 2500         5298 for my $file (@files) {
67 2500 50       112157 open my $fh, '<', $file or die "Cannnot open $file: $!";
68 2500         3833 my $src = do { local $/; <$fh> };
  2500         10744  
  2500         36493  
69              
70 2500         3832 push @violations, @{$self->_lint($src, $file)};
  2500         8479  
71             }
72              
73 2500         12793 return \@violations;
74             }
75              
76             sub lint_string {
77 0     0 0 0 my ($self, $src) = @_;
78              
79 0         0 return $self->_lint($src);
80             }
81              
82             sub _lint {
83 2500     2500   4833 my ($self, $src, $file) = @_;
84              
85 2500 50 33     18853 if (!defined $src || $src eq '') {
86 0         0 return [];
87             }
88              
89 2500         5112 my $args = $self->{args};
90              
91 2500         19571 my $lexer = Compiler::Lexer->new($file);
92 2500         394574 my $tokens = $lexer->tokenize($src);
93              
94             # list `no lint` lines
95             # TODO improve performance
96 2500         7751 my %no_lint_lines = ();
97 2500         3708 my %used_no_lint_lines = ();
98 2500         3066 my $line_num = 1;
99 2500         26181 for my $line (split /\r?\n/, $src) {
100 14458         12807 $line =~ s/"(?:[^"]*?#[^"]*?)*"//g;
101 14458         12562 $line =~ s/'(?:[^']*?#[^']*?)*'//g;
102 14458         11463 $line =~ s/\[(?:[^\[]*?#[^\]]*?)*\]//g;
103 14458 100       21724 if ($line =~ /(#.+)?##\s*no\slint(?:\s+(?:qw)?([(][^)]*[)]|"[^"]*"|'[^']*'))?/) {
104 176 100       718 next if $1; # Already commented out at before
105              
106 174         317 my $annotations = {};
107 174 100       610 if ($2) {
108 20         38 my $annotation = substr $2, 1, -1;
109 20         41 $annotations = {map {$_ => 1} grep {$_} split /[, ]/, $annotation};
  17         37  
  17         31  
110             }
111 174         515 $no_lint_lines{$line_num} = $annotations;
112             }
113 14456         12115 $line_num++;
114             }
115              
116 2500         4644 my $prohibit_useless_no_lint_policy;
117              
118             my @violations;
119 2500         2815 for my $policy (@{$self->{site_policies}}) {
  2500         6951  
120 2590 100       5869 if ($policy eq 'Perl::Lint::Policy::Miscellanea::ProhibitUselessNoLint') {
121 4         5 $prohibit_useless_no_lint_policy = $policy;
122 4         5 next;
123             }
124              
125 2586 100       6055 if ($policy eq 'Perl::Lint::Policy::Miscellanea::ProhibitUnrestrictedNoLint') {
126 6         6 push @violations, @{$policy->evaluate($file, $tokens, $src, $args, \%no_lint_lines)};
  6         60  
127 6         14 next;
128             }
129              
130              
131 2580         2776 for my $violation (@{$policy->evaluate($file, $tokens, $src, $args)}) {
  2580         20293  
132 3307         2915 my $violation_line = $violation->{line};
133 3307         2953 my $no_lint = $no_lint_lines{$violation_line};
134 3307 100 66     6344 if (!$no_lint || (keys %$no_lint > 0 && !$no_lint->{(split /::/, $violation->{policy})[-1]})) {
      66        
135 3159         2961 push @violations, $violation;
136             }
137 3307         5608 $used_no_lint_lines{$violation_line} = 1;
138             }
139             }
140              
141 2500 100       4522 if ($prohibit_useless_no_lint_policy) {
142             push @violations,
143 4         6 @{$prohibit_useless_no_lint_policy->evaluate($file, \%no_lint_lines, \%used_no_lint_lines)};
  4         27  
144             }
145              
146 2500         105125 return \@violations;
147             }
148              
149             1;
150              
151             __END__