File Coverage

blib/lib/Perl/Lint/Policy/RegularExpressions/ProhibitComplexRegexes.pm
Criterion Covered Total %
statement 46 46 100.0
branch 18 18 100.0
condition 9 11 81.8
subroutine 6 6 100.0
pod 0 1 0.0
total 79 82 96.3


line stmt bran cond sub pod time code
1             package Perl::Lint::Policy::RegularExpressions::ProhibitComplexRegexes;
2 133     133   67606 use strict;
  133         178  
  133         3193  
3 133     133   412 use warnings;
  133         149  
  133         2487  
4 133     133   770 use Perl::Lint::Constants::Type;
  133         193  
  133         60082  
5 133     133   561 use parent "Perl::Lint::Policy";
  133         217  
  133         559  
6              
7             use constant {
8 133         48053 DESC => 'Split long regexps into smaller qr// chunks',
9             EXPL => [261],
10 133     133   6784 };
  133         172  
11              
12             sub evaluate {
13 8     8 0 23 my ($class, $file, $tokens, $src, $args) = @_;
14              
15 8   100     44 my $max_characters = $args->{prohibit_complex_regexes}->{max_characters} || 60;
16              
17 8         13 my @violations;
18 8         17 my $is_reg_quote = 0;
19 8         11 my $is_delimiter_single_quote = 0;
20 8         37 for (my $i = 0, my $token_type, my $token_data; my $token = $tokens->[$i]; $i++) {
21 152         123 $token_type = $token->{type};
22 152         119 $token_data = $token->{data};
23              
24 152 100 100     400 if ($token_type == REG_DELIM) {
    100          
    100          
25 60 100       149 if ($token_data eq q{'}) {
26 2         5 $is_delimiter_single_quote = 1;
27             }
28             }
29             elsif ($token_type == REG_EXP) {
30 30         31 my $regexp = $token_data;
31              
32 30         23 my $_is_delimiter_single_quote = $is_delimiter_single_quote;
33 30         23 $is_delimiter_single_quote = 0;
34              
35 30         30 my $_is_reg_quote = $is_reg_quote;
36 30         29 $is_reg_quote = 0;
37              
38 30 100       48 if ($_is_reg_quote) {
39             # ignore when reg quote
40 2         6 next;
41             }
42              
43 28 100       53 if (!$_is_delimiter_single_quote) {
44             # replace variables
45 27         73 while ($regexp =~ /(\\*)([\$\@]\S+)/gc) {
46 14 100       27 if (length($1) % 2 == 0) {
47             # not escaped
48 12         48 $regexp =~ s/(\\*)[\$\@]\S+/$1xxxx/; # replace the variable to no-meaning 4 characters string
49             }
50             else {
51             # escaped
52 2         19 $regexp =~ s/(\\*)[\$\@]/$1X/; # replace the sigil to no-meaning character
53             }
54             }
55             }
56              
57 28         50 my $maybe_regopt = $tokens->[$i+2]; # XXX right!?
58 28 100 66     124 if (
      66        
59             $maybe_regopt &&
60             $maybe_regopt->{type} == REG_OPT &&
61             $maybe_regopt->{data} =~ /x/
62             ) {
63 2         22 $regexp =~ s/#.*?\n//gs; # reduce comments
64 2         15 $regexp =~ s/\s//g; # reduce white spaces
65             }
66              
67 28 100       72 if (length $regexp > $max_characters) {
68             push @violations, {
69             filename => $file,
70             line => $token->{line},
71 11         73 description => DESC,
72             explanation => EXPL,
73             policy => __PACKAGE__,
74             };
75             }
76             }
77             elsif ($token_type == REG_QUOTE || $token_type == REG_DOUBLE_QUOTE) {
78 2         7 $is_reg_quote = 1;
79             }
80             }
81              
82 8         41 return \@violations;
83             }
84              
85             1;
86