File Coverage

blib/lib/Perl/Critic/Policy/Bangs/ProhibitUselessRegexModifiers.pm
Criterion Covered Total %
statement 41 43 95.3
branch 15 16 93.7
condition 2 3 66.6
subroutine 13 14 92.8
pod 4 5 80.0
total 75 81 92.5


line stmt bran cond sub pod time code
1             package Perl::Critic::Policy::Bangs::ProhibitUselessRegexModifiers;
2              
3 5     5   772841 use strict;
  5         15  
  5         121  
4 5     5   25 use warnings;
  5         10  
  5         100  
5 5     5   22 use Readonly;
  5         12  
  5         230  
6              
7 5     5   27 use Perl::Critic::Utils qw{ :severities :classification :ppi };
  5         10  
  5         296  
8 5     5   1788 use base 'Perl::Critic::Policy';
  5         12  
  5         2229  
9              
10             our $VERSION = '1.12';
11              
12             Readonly::Scalar my $DESC => q{Prohibits adding "m" modifier to compiled regular expressions where it does nothing};
13             Readonly::Scalar my $EXPL => <<'EOF';
14             There is a bug in 5.8.x in that /$re/sm would incorrectly apply the
15             /sm modifiers to a regular expression. This makes the code work, but
16             for the wrong reason. In 5.10.0, this bug is "fixed" so that the
17             modifier no longer works, but no warning is emitted to tell you that
18             the modifiers are ignored.
19             http://perlbuzz.com/mechanix/2007/12/code-broken-by-regex-fixes-in.html
20             EOF
21              
22              
23 10     10 0 35650 sub supported_parameters { return () }
24 2     2 1 27 sub default_severity { return $SEVERITY_HIGH }
25 0     0 1 0 sub default_themes { return qw( bangs bugs ) }
26 7     7 1 61164 sub applies_to { return 'PPI::Token::Regexp' }
27              
28              
29             sub violates {
30 7     7 1 175 my ( $self, $elem, undef ) = @_;
31              
32              
33             # We throw a violation if all these conditions are true:
34             # 1) there's an 'm' modifier
35             # 2) the *only* thing in the regex is a compiled regex from a previous qr().
36             # 3) the modifiers are not the same in both places
37 7         37 my %mods = $elem->get_modifiers();
38 7 100 66     134 if ( $mods{'m'} || $mods{'s'} ) {
39 5         22 my $match = $elem->get_match_string();
40 5 100       113 if ( $match =~ /^\$\w+$/smx ) { # It looks like a single variable in there
41 4 100       21 if ( my $qr = _previously_assigned_quote_like_operator( $elem, $match ) ) {
42             # don't violate if both regexes are modified in the same way
43 3 100       10 if ( _sorted_modifiers( $elem ) ne _sorted_modifiers( $qr ) ) {
44 2         12 return $self->violation( $DESC, $EXPL, $elem );
45             }
46             }
47             }
48             }
49 5         68 return; #ok!;
50             }
51              
52             sub _previously_assigned_quote_like_operator {
53 4     4   14 my ( $elem, $match ) = @_;
54              
55 4 100       15 my $qlop = _find_previous_quote_like_regexp( $elem ) or return;
56              
57             # find if this previous quote-like-regexp assigned to the variable in $match
58 3         13 my $parent = $qlop->parent();
59 3 100   9   29 if ( $parent->find_any( sub { $_[1]->isa( 'PPI::Token::Symbol' ) and
  9 50       173  
60             $_[1]->content eq $match } ) ) {
61 3         67 return $qlop;
62             }
63 0         0 return;
64             }
65              
66              
67             sub _find_previous_quote_like_regexp {
68 4     4   12 my $elem = shift;
69              
70 4         8 my $qlop = $elem;
71 4         31 while ( ! $qlop->isa( 'PPI::Token::QuoteLike::Regexp' ) ) {
72             # We use previous_token instead of sprevious_sibling to get into previous statements.
73 52 100       2521 $qlop = $qlop->previous_token() or return;
74             }
75 3         222 return $qlop;
76             }
77              
78             sub _sorted_modifiers {
79 6     6   14 my $elem = shift;
80              
81 6         24 my %mods = $elem->get_modifiers();
82 6         89 return join( '', sort keys %mods );
83             }
84              
85             1;
86              
87             __END__
88             =head1 NAME
89              
90             Perl::Critic::Policy::Bangs::ProhibitUselessRegexModifiers - Adding modifiers to a regular expression made up entirely of a variable created with qr() is usually not doing what you expect.
91              
92             =head1 AFFILIATION
93              
94             This Policy is part of the L<Perl::Critic::Bangs> distribution.
95              
96             =head1 DESCRIPTION
97              
98             In older versions of perl, the modifiers on regular expressions where
99             incorrectly applied. This was fixed in 5.10, but no warnings were
100             emitted to warn the user that they were probably not getting the
101             effects they are looking for.
102              
103             Correct:
104              
105             my $regex = qr(abc)m;
106             if ( $string =~ /$regex/ ) {};
107              
108             Not what you want:
109              
110             my $regex = qr(abc);
111             if ( $string =~ /$regex/m ) {}; ## this triggers a violation of this policy.
112              
113             See the thread that starts at:
114             L<http://www.nntp.perl.org/group/perl.perl5.porters/2007/12/msg131709.html>
115             for a description of how this problem can bite the users.
116              
117             And see:
118             L<http://rt.perl.org/rt3//Public/Bug/Display.html?id=22354>
119             for a description of the bug and subsequent fix.
120              
121             =head1 CONFIGURATION
122              
123             This Policy is not configurable except for the standard options.
124              
125             =head1 AUTHOR
126              
127             Andrew Moore <amoore@mooresystems.com>
128              
129             =head1 ACKNOWLEDGMENTS
130              
131             Adapted from policies by Jeffrey Ryan Thalhammer <thaljef at cpan.org>,
132             Thanks to Andy Lester, "<andy at petdance.com>" for pointing out this common problem.
133              
134             =head1 COPYRIGHT
135              
136             Copyright (c) 2007-2013 Andy Lester <andy@petdance.com> and Andrew
137             Moore <amoore@mooresystems.com>
138              
139             This library is free software; you can redistribute it and/or modify it
140             under the terms of the Artistic License 2.0.
141              
142             =cut