File Coverage

blib/lib/Perl/Lint/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm
Criterion Covered Total %
statement 57 57 100.0
branch 20 22 90.9
condition 7 9 77.7
subroutine 8 8 100.0
pod 0 1 0.0
total 92 97 94.8


line stmt bran cond sub pod time code
1             package Perl::Lint::Policy::RegularExpressions::ProhibitEnumeratedClasses;
2 134     134   70495 use strict;
  134         178  
  134         3845  
3 134     134   427 use warnings;
  134         160  
  134         2552  
4 134     134   444 use List::Util ();
  134         151  
  134         1718  
5 134     134   752 use Perl::Lint::Constants::Type;
  134         180  
  134         61515  
6 134     134   562 use parent "Perl::Lint::Policy";
  134         162  
  134         603  
7              
8             use constant {
9 134         70822 DESC => 'Use named character classes (%s VS. %s)',
10             EXPL => [248],
11 134     134   6826 };
  134         186  
12              
13             my @patterns = (
14             [q{ },'\\t','\\r','\\n'] => ['\\s', '\\S'],
15             ['A-Z','a-z','0-9','_'] => ['\\w', '\\W'],
16             ['A-Z','a-z'] => ['[[:alpha:]]','[[:^alpha:]]'],
17             ['A-Z'] => ['[[:upper:]]','[[:^upper:]]'],
18             ['a-z'] => ['[[:lower:]]','[[:^lower:]]'],
19             ['0-9'] => ['\\d','\\D'],
20             ['\w'] => [undef, '\\W'],
21             ['\s'] => [undef, '\\S'],
22             );
23              
24             my %ordinals = (
25             ord "\n" => '\\n',
26             ord "\f" => '\\f',
27             ord "\r" => '\\r',
28             ord q< > => q< >,
29             );
30              
31             sub evaluate {
32 8     8 0 11 my ($class, $file, $tokens, $src, $args) = @_;
33              
34 8         8 my @violations;
35 8         29 for (my $i = 0, my $token_type; my $token = $tokens->[$i]; $i++) {
36 201         145 $token_type = $token->{type};
37              
38 201 100 66     554 if ($token_type == REG_EXP || $token_type == REG_REPLACE_FROM) {
39 32         34 my $regex = $token->{data};
40 32 100       131 if (my @captures = $regex =~ / (\\)* \[ (\^?) (.+) ] /gx) {
41 29         38 while (@captures) {
42 29         26 my $backslashes = shift @captures;
43 29         24 my $is_negate = shift @captures;
44 29         22 my $in_brackets = shift @captures;
45              
46 29 100 66     51 if ($backslashes && length($backslashes) % 2 != 0) { # escaped
47 1         4 next;
48             }
49              
50 28         82 my @parts = $in_brackets =~ /([^\\]-[^\\] | [_ ] | \\[trnws])/gx;
51 28         30 my @octs = $in_brackets =~ /\\0([0-7]+)/gx;
52 28         30 for my $oct (@octs) {
53 2 50       7 if (my $chr = $ordinals{oct $oct}) {
54 2         3 push @parts, $chr;
55             }
56             }
57              
58 28         31 my @hexs = $in_brackets =~ /\\x\{?([0-9a-f]+)}?/gx;
59 28         17 for my $hex (@hexs) {
60 5 100       10 if (my $chr = $ordinals{hex $hex}) {
61 4         6 push @parts, $chr;
62             }
63             }
64              
65 28         33 my %parts = map {$_ => 1} @parts;
  69         143  
66 28         51 for (my $j = 0; $j < @patterns; $j += 2) {
67 114 100   161   155 if (List::Util::all { exists $parts{$_} } @{$patterns[$j]}) {
  161         302  
  114         169  
68 26         17 my $index = 0;
69 26 100       36 if ($is_negate) {
70 13         10 $index = 1;
71             }
72              
73 26 100 100     60 if ($is_negate && ! defined $patterns[$j+1]->[0]) {
74             # the [^\w] => \W rule only applies if \w is the only token.
75             # that is it does not apply to [^\w\s]
76 4 50       9 next if 1 != scalar keys %parts;
77             }
78              
79 26 100       29 my $orig = join q{}, '[', ($is_negate ? q{^} : ()), @{$patterns[$j]}, ']';
  26         42  
80 26 100       53 if (defined (my $improvement = $patterns[$j+1]->[$index])) {
81             push @violations, {
82             filename => $file,
83             line => $token->{line},
84 24         103 description => sprintf(DESC, $orig, $improvement),
85             explanation => EXPL,
86             policy => __PACKAGE__,
87             };
88 24         124 last;
89             }
90             }
91             }
92             }
93             }
94             }
95             }
96              
97 8         26 return \@violations;
98             }
99              
100             1;
101