File Coverage

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


line stmt bran cond sub pod time code
1             package Perl::Critic::Policy::Bangs::ProhibitUselessRegexModifiers;
2              
3 4     4   4330 use strict;
  4         9  
  4         163  
4 4     4   21 use warnings;
  4         35  
  4         124  
5 4     4   22 use Readonly;
  4         7  
  4         235  
6              
7 4     4   23 use Perl::Critic::Utils qw{ :severities :classification :ppi };
  4         7  
  4         313  
8 4     4   1893 use base 'Perl::Critic::Policy';
  4         9  
  4         2231  
9              
10             our $VERSION = '1.11_02';
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 44546 sub supported_parameters { return () }
24 2     2 1 29 sub default_severity { return $SEVERITY_HIGH }
25 0     0 1 0 sub default_themes { return qw( bangs bugs ) }
26 7     7 1 60207 sub applies_to { return 'PPI::Token::Regexp' }
27              
28              
29             sub violates {
30 7     7 1 163 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         43 my %mods = $elem->get_modifiers();
38 7 100 100     146 if ( $mods{'m'} || $mods{'s'} ) {
39 5         28 my $match = $elem->get_match_string();
40 5 100       105 if ( $match =~ /^\$\w+$/smx ) { # It looks like a single variable in there
41 4 100       14 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       13 if ( _sorted_modifiers( $elem ) ne _sorted_modifiers( $qr ) ) {
44 2         25 return $self->violation( $DESC, $EXPL, $elem );
45             }
46             }
47             }
48             }
49 5         62 return; #ok!;
50             }
51              
52             sub _previously_assigned_quote_like_operator {
53 4     4   8 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         14 my $parent = $qlop->parent();
59 3 100   9   35 if ( $parent->find_any( sub { $_[1]->isa( 'PPI::Token::Symbol' ) and
  9 50       170  
60             $_[1]->content eq $match } ) ) {
61 3         62 return $qlop;
62             }
63 0         0 return;
64             }
65              
66              
67             sub _find_previous_quote_like_regexp {
68 4     4   8 my $elem = shift;
69              
70 4         5 my $qlop = $elem;
71 4         32 while ( ! $qlop->isa( 'PPI::Token::QuoteLike::Regexp' ) ) {
72             # We use previous_token instead of sprevious_sibling to get into previous statements.
73 52 100       1655 $qlop = $qlop->previous_token() or return;
74             }
75 3         127 return $qlop;
76             }
77              
78             sub _sorted_modifiers {
79 6     6   9 my $elem = shift;
80              
81 6         20 my %mods = $elem->get_modifiers();
82 6         90 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