← Index
NYTProf Performance Profile   « line view »
For /Users/timbo/perl5/perlbrew/perls/perl-5.18.2/bin/perlcritic
  Run on Sat Mar 19 22:12:22 2016
Reported on Sat Mar 19 22:14:11 2016

Filename/Users/timbo/perl5/perlbrew/perls/perl-5.18.2/lib/site_perl/5.18.2/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm
StatementsExecuted 36 statements in 2.63ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11116┬Ás16┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@10Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@10
1118┬Ás12┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@12Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@12
1118┬Ás38┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@14Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@14
1118┬Ás27┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@17Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@17
1118┬Ás26┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@20Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@20
1118┬Ás67┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@25Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@25
1118┬Ás136┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@16Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@16
1118┬Ás27┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@18Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@18
1117┬Ás376┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@15Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@15
1117┬Ás415┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@21Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@21
1117┬Ás18┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::BEGIN@11Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@11
1116┬Ás7┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::default_severityPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::default_severity
1112┬Ás2┬ÁsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::supported_parametersPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::supported_parameters
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::__ANON__[:126]Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:126]
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::__ANON__[:128]Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:128]
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::__ANON__[:193]Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:193]
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::__ANON__[:301]Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:301]
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::__ANON__[:303]Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:303]
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::__ANON__[:415]Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:415]
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::__ANON__[:450]Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:450]
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_block_is_slurpyPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_block_is_slurpy
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_check_for_magicPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_check_for_magic
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_check_if_in_while_condition_or_blockPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_check_if_in_while_condition_or_block
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_check_node_childrenPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_check_node_children
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_check_rest_of_statementPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_check_rest_of_statement
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_enough_assignmentsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_enough_assignments
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_enough_magicPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_enough_magic
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_enough_uses_in_regexpPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_enough_uses_in_regexp
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_has_array_sigilPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_has_array_sigil
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_has_hash_sigilPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_has_hash_sigil
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_is_condition_of_if_statementPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_is_condition_of_if_statement
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_is_double_quotish_elementPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_is_double_quotish_element
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_is_in_slurpy_array_contextPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_is_in_slurpy_array_context
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_is_preceded_by_array_or_hash_castPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_is_preceded_by_array_or_hash_cast
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_make_regexp_checkerPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_make_regexp_checker
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_mark_magicPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_mark_magic
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_mark_magic_in_contentPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_mark_magic_in_content
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_mark_magic_subscripted_codePerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_mark_magic_subscripted_code
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_record_named_capturePerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_record_named_capture
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_record_numbered_capturePerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_record_numbered_capture
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_record_subscripted_capturePerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_record_subscripted_capture
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_skip_lhsPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_skip_lhs
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::_symbol_is_slurpyPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_symbol_is_slurpy
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::applies_toPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::applies_to
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::default_themesPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::default_themes
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::::violatesPerl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::violates
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1##############################################################################
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
6##############################################################################
7
8package Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture;
9
10239┬Ás116┬Ás
# spent 16┬Ás within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@10 which was called: # once (16┬Ás+0s) by Module::Pluggable::Object::_require at line 10
use 5.006001;
11220┬Ás229┬Ás
# spent 18┬Ás (7+11) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@11 which was called: # once (7┬Ás+11┬Ás) by Module::Pluggable::Object::_require at line 11
use strict;
# spent 18┬Ás making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@11 # spent 11┬Ás making 1 call to strict::import
12223┬Ás215┬Ás
# spent 12┬Ás (8+4) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@12 which was called: # once (8┬Ás+4┬Ás) by Module::Pluggable::Object::_require at line 12
use warnings;
# spent 12┬Ás making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@12 # spent 4┬Ás making 1 call to warnings::import
13
14222┬Ás268┬Ás
# spent 38┬Ás (8+30) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@14 which was called: # once (8┬Ás+30┬Ás) by Module::Pluggable::Object::_require at line 14
use Carp;
# spent 38┬Ás making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@14 # spent 30┬Ás making 1 call to Exporter::import
15228┬Ás2746┬Ás
# spent 376┬Ás (7+369) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@15 which was called: # once (7┬Ás+369┬Ás) by Module::Pluggable::Object::_require at line 15
use English qw(-no_match_vars);
# spent 376┬Ás making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@15 # spent 369┬Ás making 1 call to English::import
16222┬Ás2265┬Ás
# spent 136┬Ás (8+129) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@16 which was called: # once (8┬Ás+129┬Ás) by Module::Pluggable::Object::_require at line 16
use List::MoreUtils qw(none);
# spent 136┬Ás making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@16 # spent 129┬Ás making 1 call to Exporter::Tiny::import
17221┬Ás246┬Ás
# spent 27┬Ás (8+19) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@17 which was called: # once (8┬Ás+19┬Ás) by Module::Pluggable::Object::_require at line 17
use Readonly;
# spent 27┬Ás making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@17 # spent 19┬Ás making 1 call to Exporter::import
18222┬Ás247┬Ás
# spent 27┬Ás (8+20) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@18 which was called: # once (8┬Ás+20┬Ás) by Module::Pluggable::Object::_require at line 18
use Scalar::Util qw(refaddr);
# spent 27┬Ás making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@18 # spent 20┬Ás making 1 call to Exporter::import
19
20224┬Ás245┬Ás
# spent 26┬Ás (8+19) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@20 which was called: # once (8┬Ás+19┬Ás) by Module::Pluggable::Object::_require at line 20
use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
# spent 26┬Ás making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@20 # spent 19┬Ás making 1 call to Exporter::import
211200ns
# spent 415┬Ás (7+408) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@21 which was called: # once (7┬Ás+408┬Ás) by Module::Pluggable::Object::_require at line 24
use Perl::Critic::Utils qw{
22 :booleans :characters :severities hashify precedence_of
23 split_nodes_on_comma
24125┬Ás2823┬Ás};
# spent 415┬Ás making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@21 # spent 408┬Ás making 1 call to Exporter::import
2522.34ms2127┬Ás
# spent 67┬Ás (8+60) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@25 which was called: # once (8┬Ás+60┬Ás) by Module::Pluggable::Object::_require at line 25
use base 'Perl::Critic::Policy';
# spent 67┬Ás making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@25 # spent 60┬Ás making 1 call to base::import
26
271700nsour $VERSION = '1.121';
28
29#-----------------------------------------------------------------------------
30
3112┬Ás132┬ÁsReadonly::Scalar my $WHILE => q{while};
# spent 32┬Ás making 1 call to Readonly::Scalar
32
3313┬Ás227┬ÁsReadonly::Hash my %CAPTURE_REFERENCE => hashify( qw{ $+ $- } );
# spent 24┬Ás making 1 call to Readonly::Hash # spent 3┬Ás making 1 call to Perl::Critic::Utils::hashify
34111┬Ás544┬ÁsReadonly::Hash my %CAPTURE_REFERENCE_ENGLISH => (
# spent 36┬Ás making 1 call to Readonly::Hash # spent 3┬Ás making 1 call to Readonly::Hash::FIRSTKEY # spent 3┬Ás making 2 calls to Readonly::Hash::NEXTKEY, avg 1┬Ás/call # spent 2┬Ás making 1 call to Perl::Critic::Utils::hashify
35 hashify( qw{ $LAST_PAREN_MATCH $LAST_MATCH_START $LAST_MATCH_END } ),
36 %CAPTURE_REFERENCE );
37
3811┬Ás123┬ÁsReadonly::Scalar my $DESC => q{Only use a capturing group if you plan to use the captured value};
# spent 23┬Ás making 1 call to Readonly::Scalar
3912┬Ás142┬ÁsReadonly::Scalar my $EXPL => [252];
# spent 42┬Ás making 1 call to Readonly::Scalar
40
41#-----------------------------------------------------------------------------
42
4315┬Ás
# spent 2┬Ás within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::supported_parameters which was called: # once (2┬Ás+0s) by Perl::Critic::Policy::new at line 88 of Perl/Critic/Policy.pm
sub supported_parameters { return qw() }
4412┬Ás
# spent 7┬Ás (6+1) within Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::default_severity which was called: # once (6┬Ás+1┬Ás) by Perl::Critic::Policy::get_severity at line 331 of Perl/Critic/Policy.pm
sub default_severity { return $SEVERITY_MEDIUM }
45sub default_themes { return qw( core pbp maintenance ) }
46sub applies_to {
47 return qw< PPI::Token::Regexp::Match PPI::Token::Regexp::Substitute >
48}
49
50#-----------------------------------------------------------------------------
51
5211┬Ás120┬ÁsReadonly::Scalar my $NUM_CAPTURES_FOR_GLOBAL => 100; # arbitrarily large number
# spent 20┬Ás making 1 call to Readonly::Scalar
53
54sub violates {
55 my ( $self, $elem, $doc ) = @_;
56
57 # optimization: don't bother parsing the regexp if there are no parens
58 return if 0 > index $elem->content(), '(';
59
60 my $re = $doc->ppix_regexp_from_element( $elem ) or return;
61 $re->failures() and return;
62
63 my $ncaptures = $re->max_capture_number() or return;
64
65 my @captures; # List of expected captures
66 $#captures = $ncaptures - 1;
67
68 my %named_captures; # List of expected named captures.
69 # Unlike the numbered capture logic, %named_captures
70 # entries are made undefined when a use of the name is
71 # found. Otherwise two hashes would be needed, one to
72 # become defined when a use is found, and one to hold
73 # the mapping of name to number.
74 foreach my $struct ( @{ $re->find( 'PPIx::Regexp::Structure::NamedCapture'
75 ) || [] } ) {
76 # There can be more than one capture with the same name, so we need to
77 # record all of them. There will be duplications if the 'branch reset'
78 # "(?| ... )" pattern is used, but this is benign given how numbered
79 # captures are recorded.
80 push @{ $named_captures{ $struct->name() } ||= [] }, $struct->number();
81 }
82
83 # Look for references to the capture in the regex itself
84 return if _enough_uses_in_regexp( $re, \@captures, \%named_captures, $doc );
85
86 if ( $re->modifier_asserted( 'g' )
87 and not _check_if_in_while_condition_or_block( $elem ) ) {
88 $ncaptures = $NUM_CAPTURES_FOR_GLOBAL;
89 $#captures = $ncaptures - 1;
90 }
91
92 return if _enough_assignments($elem, \@captures) && !%named_captures;
93 return if _is_in_slurpy_array_context($elem) && !%named_captures;
94 return if _enough_magic($elem, $re, \@captures, \%named_captures, $doc);
95
96 return $self->violation( $DESC, $EXPL, $elem );
97}
98
99# Find uses of both numbered and named capture variables in the regexp itself.
100# Return true if all are used.
101sub _enough_uses_in_regexp {
102 my ( $re, $captures, $named_captures, $doc ) = @_;
103
104 # Look for references to the capture in the regex itself. Note that this
105 # will also find backreferences in the replacement string of s///.
106 foreach my $token ( @{ $re->find( 'PPIx::Regexp::Token::Reference' )
107 || [] } ) {
108 if ( $token->is_named() ) {
109 _record_named_capture( $token->name(), $captures, $named_captures );
110 } else {
111 _record_numbered_capture( $token->absolute(), $captures );
112 }
113 }
114
115 foreach my $token ( @{ $re->find(
116 'PPIx::Regexp::Token::Code' ) || [] } ) {
117 my $ppi = $token->ppi() or next;
118 _check_node_children( $ppi, {
119 regexp => $re,
120 numbered_captures => $captures,
121 named_captures => $named_captures,
122 document => $doc,
123 }, _make_regexp_checker() );
124 }
125
126 return ( none {not defined $_} @{$captures} )
127 && ( !%{$named_captures} ||
128 none {defined $_} values %{$named_captures} );
129}
130
131sub _enough_assignments {
132 my ($elem, $captures) = @_;
133
134 # look backward for the assignment operator
135 my $psib = $elem->sprevious_sibling;
136 SIBLING:
137 while (1) {
138 return if !$psib;
139 if ($psib->isa('PPI::Token::Operator')) {
140 last SIBLING if q{=} eq $psib;
141 return if q{!~} eq $psib;
142 }
143 $psib = $psib->sprevious_sibling;
144 }
145
146 $psib = $psib->sprevious_sibling;
147 return if !$psib; # syntax error: '=' at the beginning of a statement???
148
149 if ($psib->isa('PPI::Token::Symbol')) {
150 # @foo = m/(foo)/
151 # @$foo = m/(foo)/
152 # %foo = m/(foo)/
153 # %$foo = m/(foo)/
154 return $TRUE if _symbol_is_slurpy($psib);
155
156 } elsif ($psib->isa('PPI::Structure::Block')) {
157 # @{$foo} = m/(foo)/
158 # %{$foo} = m/(foo)/
159 return $TRUE if _block_is_slurpy($psib);
160
161 } elsif ($psib->isa('PPI::Structure::List')) {
162 # () = m/(foo)/
163 # ($foo) = m/(foo)/
164 # ($foo,$bar) = m/(foo)(bar)/
165 # (@foo) = m/(foo)(bar)/
166 # ($foo,@foo) = m/(foo)(bar)/
167 # ($foo,@$foo) = m/(foo)(bar)/
168 # ($foo,@{$foo}) = m/(foo)(bar)/
169
170 my @args = $psib->schildren;
171 return $TRUE if not @args; # empty list (perhaps the "goatse" operator) is slurpy
172
173 # Forward looking: PPI might change in v1.200 so schild(0) is a
174 # PPI::Statement::Expression.
175 if ( 1 == @args && $args[0]->isa('PPI::Statement::Expression') ) {
176 @args = $args[0]->schildren;
177 }
178
179 my @parts = split_nodes_on_comma(@args);
180 PART:
181 for my $i (0 .. $#parts) {
182 if (1 == @{$parts[$i]}) {
183 my $var = $parts[$i]->[0];
184 if ($var->isa('PPI::Token::Symbol') || $var->isa('PPI::Token::Cast')) {
185 return $TRUE if _has_array_sigil($var);
186 }
187 }
188 _record_numbered_capture( $i + 1, $captures );
189 # ith variable capture
190 }
191 }
192
193 return none {not defined $_} @{$captures};
194}
195
196sub _symbol_is_slurpy {
197 my ($symbol) = @_;
198
199 return $TRUE if _has_array_sigil($symbol);
200 return $TRUE if _has_hash_sigil($symbol);
201 return $TRUE if _is_preceded_by_array_or_hash_cast($symbol);
202 return;
203}
204
205sub _has_array_sigil {
206 my ($elem) = @_; # Works on PPI::Token::Symbol and ::Cast
207
208 return q{@} eq substr $elem->content, 0, 1;
209}
210
211sub _has_hash_sigil {
212 my ($elem) = @_; # Works on PPI::Token::Symbol and ::Cast
213
214 return q{%} eq substr $elem->content, 0, 1;
215}
216
217sub _block_is_slurpy {
218 my ($block) = @_;
219
220 return $TRUE if _is_preceded_by_array_or_hash_cast($block);
221 return;
222}
223
224sub _is_preceded_by_array_or_hash_cast {
225 my ($elem) = @_;
226 my $psib = $elem->sprevious_sibling;
227 my $cast;
228 while ($psib && $psib->isa('PPI::Token::Cast')) {
229 $cast = $psib;
230 $psib = $psib->sprevious_sibling;
231 }
232 return if !$cast;
233 my $sigil = substr $cast->content, 0, 1;
234 return q{@} eq $sigil || q{%} eq $sigil;
235}
236
237sub _is_in_slurpy_array_context {
238 my ($elem) = @_;
239
240 # return true is the result of the regexp is passed to a subroutine.
241 # doesn't check for array context due to assignment.
242
243 # look backward for explicit regex operator
244 my $psib = $elem->sprevious_sibling;
245 if ($psib && $psib eq q{=~}) {
246 # Track back through value
247 $psib = _skip_lhs($psib);
248 }
249
250 if (!$psib) {
251 my $parent = $elem->parent;
252 return if !$parent;
253 if ($parent->isa('PPI::Statement')) {
254 $parent = $parent->parent;
255 return if !$parent;
256 }
257
258 # Return true if we have a list that isn't part of a foreach loop.
259 # TECHNICAL DEBT: This code is basically shared with
260 # RequireCheckingReturnValueOfEval. I don't want to put this code
261 # into Perl::Critic::Utils::*, but I don't have time to sort out
262 # PPIx::Utilities::Structure::List yet.
263 if ( $parent->isa('PPI::Structure::List') ) {
264 my $parent_statement = $parent->statement() or return $TRUE;
265 return $TRUE if not
266 $parent_statement->isa('PPI::Statement::Compound');
267 return $TRUE if $parent_statement->type() ne 'foreach';
268 }
269
270 return $TRUE if $parent->isa('PPI::Structure::Constructor');
271 if ($parent->isa('PPI::Structure::Block')) {
272 return $TRUE
273 if
274 refaddr($elem->statement)
275 eq refaddr([$parent->schildren]->[-1]);
276 }
277 return;
278 }
279 if ($psib->isa('PPI::Token::Operator')) {
280 # most operators kill slurpiness (except assignment, which is handled elsewhere)
281 return $TRUE if q{,} eq $psib;
282 return;
283 }
284 return $TRUE;
285}
286
287sub _skip_lhs {
288 my ($elem) = @_;
289
290 # TODO: better implementation to handle casts, expressions, subcalls, etc.
291 $elem = $elem->sprevious_sibling();
292
293 return $elem;
294}
295
296sub _enough_magic {
297 my ($elem, $re, $captures, $named_captures, $doc) = @_;
298
299 _check_for_magic($elem, $re, $captures, $named_captures, $doc);
300
301 return ( none {not defined $_} @{$captures} )
302 && ( !%{$named_captures} ||
303 none {defined $_} values %{$named_captures} );
304}
305
306# void return
307sub _check_for_magic {
308 my ($elem, $re, $captures, $named_captures, $doc) = @_;
309
310 # Search for $1..$9 in :
311 # * the rest of this statement
312 # * subsequent sibling statements
313 # * if this is in a conditional boolean, the if/else bodies of the conditional
314 # * if this is in a while/for condition, the loop body
315 # But NO intervening regexps!
316
317 # Package up the usual arguments for _check_rest_of_statement().
318 my $arg = {
319 regexp => $re,
320 numbered_captures => $captures,
321 named_captures => $named_captures,
322 document => $doc,
323 };
324
325 # Capture whether or not the regular expression is negated -- that
326 # is, whether it is preceded by the '!~' binding operator.
327 if ( my $prior_token = $elem->sprevious_sibling() ) {
328 $arg->{negated} = $prior_token->isa( 'PPI::Token::Operator' ) &&
329 q<!~> eq $prior_token->content();
330 }
331
332 return if ! _check_rest_of_statement( $elem, $arg );
333
334 my $parent = $elem->parent();
335 while ($parent && ! $parent->isa('PPI::Statement::Sub')) {
336 return if ! _check_rest_of_statement( $parent, $arg );
337 $parent = $parent->parent();
338 }
339
340 return;
341}
342
343# Check if we are in the condition or block of a 'while'
344sub _check_if_in_while_condition_or_block {
345 my ( $elem ) = @_;
346 $elem or return;
347
348 my $parent = $elem->parent() or return;
349 $parent->isa( 'PPI::Statement' ) or return;
350
351 my $item = $parent = $parent->parent() or return;
352 if ( $item->isa( 'PPI::Structure::Block' ) ) {
353 $item = $item->sprevious_sibling() or return;
354 }
355 $item->isa( 'PPI::Structure::Condition' ) or return;
356
357 $item = $item->sprevious_sibling() or return;
358 $item->isa( 'PPI::Token::Word' ) or return;
359
360 return $WHILE eq $item->content();
361}
362
363{
364 # Shortcut operators '||', '//', and 'or' can cause everything after
365 # them to be skipped. 'and' trumps '||' and '//', and causes things
366 # to be evaluated again. The value is true to skip, false to cancel
367 # skipping.
36822┬Ás138┬Ás Readonly::Hash my %SHORTCUT_OPERATOR => (
# spent 38┬Ás making 1 call to Readonly::Hash
369 q<||> => $FALSE,
370 q<//> => $FALSE,
371 and => $TRUE,
372 or => $FALSE,
373 );
374
375 # RT #38942
376 # The issue in the ticket is that in something like
377 # if ( /(a)/ || /(b) ) {
378 # say $1
379 # }
380 # the capture variable can come from either /(a)/ or /(b)/. If we
381 # don't take into account the short-cutting nature of the '||' we
382 # erroneously conclude that the capture in /(a)/ is not used. So we
383 # need to skip every regular expression after an alternation.
384 #
385 # The trick is that we want to still mark magic variables, because
386 # of code like
387 # my $foo = $1 || $2;
388 # so we can't just ignore everything after an alternation.
389 #
390 # To do all this correctly, we have to track precedence, and start
391 # paying attention again if an 'and' is found after a '||'.
392
393 # Subroutine _make_regexp_checker() manufactures a snippet of code
394 # which is used to track regular expressions. It takes one optional
395 # argument, which is the snippet used to track the parent object's
396 # regular expressions.
397 #
398 # The snippet is passed each token encountered, and returns true if
399 # the scan for capture variables is to be stopped. This will happen
400 # if the token is a regular expression which is _not_ to the right
401 # of an alternation operator ('||', '//', or 'or'), or it _is_ to
402 # the right of an 'and', without an intervening alternation
403 # operator.
404 #
405 # If _make_regexp_checker() was passed a snippet which
406 # returns false on encountering a regular expression, the returned
407 # snippet always returns false, for the benefit of code like
408 # /(a)/ || ( /(b)/ || /(c)/ ).
409
410 sub _make_regexp_checker {
411 my ( $parent ) = @_;
412
413 $parent
414 and not $parent->()
415 and return sub { return $FALSE };
416
417 my $check = $TRUE;
418 my $precedence = 0;
419
420 return sub {
421 my ( $elem ) = @_;
422
423 $elem or return $check;
424
425 $elem->isa( 'PPI::Token::Regexp' )
426 and return $check;
427
428 if ( $elem->isa( 'PPI::Token::Structure' )
429 && q<;> eq $elem->content() ) {
430 $check = $TRUE;
431 $precedence = 0;
432 return $FALSE;
433 }
434
435 $elem->isa( 'PPI::Token::Operator' )
436 or return $FALSE;
437
438 my $content = $elem->content();
439 defined( my $oper_check = $SHORTCUT_OPERATOR{$content} )
440 or return $FALSE;
441
442 my $oper_precedence = precedence_of( $content );
443 $oper_precedence >= $precedence
444 or return $FALSE;
445
446 $precedence = $oper_precedence;
447 $check = $oper_check;
448
449 return $FALSE;
450 };
451 }
452}
453
454# false if we hit another regexp
455# The arguments are:
456# $elem - The PPI::Element whose siblings are to be checked;
457# $arg - A hash reference containing the following keys:
458# regexp => the relevant PPIx::Regexp object;
459# numbered_captures => a reference to the array used to track the
460# use of numbered captures;
461# named_captures => a reference to the hash used to track the
462# use of named captures;
463# negated => true if the regexp was bound to its target with the
464# '!~' operator;
465# document => a reference to the Perl::Critic::Document;
466# Converted to passing the arguments everyone gets in a hash because of
467# the need to add the 'negated' argument, which would put us at six
468# arguments.
469sub _check_rest_of_statement {
470 my ( $elem, $arg ) = @_;
471
472 my $checker = _make_regexp_checker();
473 my $nsib = $elem->snext_sibling;
474
475 # If we are an if (or elsif) and the result of the regexp is
476 # negated, we skip the first block found. RT #69867
477 if ( $arg->{negated} && _is_condition_of_if_statement( $elem ) ) {
478 while ( $nsib && ! $nsib->isa( 'PPI::Structure::Block' ) ) {
479 $nsib = $nsib->snext_sibling();
480 }
481 $nsib and $nsib = $nsib->snext_sibling();
482 }
483
484 while ($nsib) {
485 return if $checker->($nsib);
486 if ($nsib->isa('PPI::Node')) {
487 return if ! _check_node_children($nsib, $arg, $checker );
488 } else {
489 _mark_magic( $nsib, $arg->{regexp}, $arg->{numbered_captures},
490 $arg->{named_captures}, $arg->{document} );
491 }
492 $nsib = $nsib->snext_sibling;
493 }
494 return $TRUE;
495}
496
497{
498
49922┬Ás222┬Ás Readonly::Hash my %IS_IF_STATEMENT => hashify( qw{ if elsif } );
# spent 19┬Ás making 1 call to Readonly::Hash # spent 2┬Ás making 1 call to Perl::Critic::Utils::hashify
500
501 # Return true if the argument is the condition of an if or elsif
502 # statement, otherwise return false.
503 sub _is_condition_of_if_statement {
504 my ( $elem ) = @_;
505 $elem
506 and $elem->isa( 'PPI::Structure::Condition' )
507 or return $FALSE;
508 my $psib = $elem->sprevious_sibling()
509 or return $FALSE;
510 $psib->isa( 'PPI::Token::Word' )
511 or return $FALSE;
512 return $IS_IF_STATEMENT{ $psib->content() };
513
514 }
515}
516
517# false if we hit another regexp
518# The arguments are:
519# $elem - The PPI::Node whose children are to be checked;
520# $arg - A hash reference containing the following keys:
521# regexp => the relevant PPIx::Regexp object;
522# numbered_captures => a reference to the array used to track the
523# use of numbered captures;
524# named_captures => a reference to the hash used to track the
525# use of named captures;
526# document => a reference to the Perl::Critic::Document;
527# $parent_checker - The parent's regexp checking code snippet,
528# manufactured by _make_regexp_checker(). This argument is not in
529# the $arg hash because that hash is shared among levels of the
530# parse tree, whereas the regexp checker is not.
531# TODO the things in the $arg hash are widely shared among the various
532# pieces/parts of this policy; maybe more subroutines should use this
533# hash rather than passing all this stuff around as individual
534# arguments. This particular subroutine got the hash-reference treatment
535# because Subroutines::ProhibitManyArgs started complaining when the
536# checker argument was added.
537sub _check_node_children {
538 my ($elem, $arg, $parent_checker) = @_;
539
540 # caveat: this will descend into subroutine definitions...
541
542 my $checker = _make_regexp_checker($parent_checker);
543 for my $child ($elem->schildren) {
544 return if $checker->($child);
545 if ($child->isa('PPI::Node')) {
546 return if ! _check_node_children($child, $arg, $checker);
547 } else {
548 _mark_magic($child, $arg->{regexp},
549 $arg->{numbered_captures}, $arg->{named_captures},
550 $arg->{document});
551 }
552 }
553 return $TRUE;
554}
555
556sub _mark_magic {
557 my ($elem, $re, $captures, $named_captures, $doc) = @_;
558
559 # If we're a double-quotish element, we need to grub through its
560 # content. RT #38942
561 if ( _is_double_quotish_element( $elem ) ) {
562 _mark_magic_in_content(
563 $elem->content(), $re, $captures, $named_captures, $doc );
564 return;
565 }
566
567 # Ditto a here document, though the logic is different. RT #38942
568 if ( $elem->isa( 'PPI::Token::HereDoc' ) ) {
569 $elem->content() =~ m/ \A << \s* ' /sxm
570 or _mark_magic_in_content(
571 join( $EMPTY, $elem->heredoc() ), $re, $captures,
572 $named_captures, $doc );
573 return;
574 }
575
576 # Only interested in magic, or known English equivalent.
577 my $content = $elem->content();
578 my $capture_ref = $doc->uses_module( 'English' ) ?
579 \%CAPTURE_REFERENCE_ENGLISH :
580 \%CAPTURE_REFERENCE;
581 $elem->isa( 'PPI::Token::Magic' )
582 or $capture_ref->{$content}
583 or return;
584
585 if ( $content =~ m/ \A \$ ( \d+ ) /xms ) {
586
587 # Record if we see $1, $2, $3, ...
588 my $num = $1;
589 if (0 < $num) { # don't mark $0
590 # Only mark the captures we really need -- don't mark superfluous magic vars
591 if ($num <= @{$captures}) {
592 _record_numbered_capture( $num, $captures );
593 }
594 }
595 } elsif ( $capture_ref->{$content} ) {
596 _mark_magic_subscripted_code( $elem, $re, $captures, $named_captures );
597 }
598 return;
599}
600
601# Record a named capture referenced by a hash or array found in code.
602# The arguments are:
603# $elem - The element that represents a subscripted capture variable;
604# $re - The PPIx::Regexp object;
605# $captures - A reference to the numbered capture array;
606# $named_captures - A reference to the named capture hash.
607sub _mark_magic_subscripted_code {
608 my ( $elem, $re, $captures, $named_captures ) = @_;
609 my $subscr = $elem->snext_sibling() or return;
610 $subscr->isa( 'PPI::Structure::Subscript' ) or return;
611 my $subval = $subscr->content();
612 _record_subscripted_capture(
613 $elem->content(), $subval, $re, $captures, $named_captures );
614 return;
615}
616
617# Find capture variables in the content of a double-quotish thing, and
618# record their use. RT #38942. The arguments are:
619# $content - The content() ( or heredoc() in the case of a here
620# document) to be analyzed;
621# $re - The PPIx::Regexp object;
622# $captures - A reference to the numbered capture array;
623# $named_captures - A reference to the named capture hash.
624sub _mark_magic_in_content {
625 my ( $content, $re, $captures, $named_captures, $doc ) = @_;
626
627 my $capture_ref = $doc->uses_module( 'English' ) ?
628 \%CAPTURE_REFERENCE_ENGLISH :
629 \%CAPTURE_REFERENCE;
630
631 while ( $content =~ m< ( \$ (?:
632 [{] (?: \w+ | . ) [}] | \w+ | . ) ) >sxmg ) {
633 my $name = $1;
634 $name =~ s/ \A \$ [{] /\$/sxm;
635 $name =~ s/ [}] \z //sxm;
636
637 if ( $name =~ m/ \A \$ ( \d+ ) \z /sxm ) {
638
639 my $num = $1;
640 0 < $num
641 and $num <= @{ $captures }
642 and _record_numbered_capture( $num, $captures );
643
644 } elsif ( $capture_ref->{$name} &&
645 $content =~ m/ \G ( [{] [^}]+ [}] | [[] [^]] []] ) /smxgc )
646 {
647 _record_subscripted_capture(
648 $name, $1, $re, $captures, $named_captures );
649
650 }
651 }
652 return;
653}
654
655# Return true if the given element is double-quotish. Always returns
656# false for a PPI::Token::HereDoc, since they're a different beast.
657# RT #38942.
658sub _is_double_quotish_element {
659 my ( $elem ) = @_;
660
661 $elem or return;
662
663 my $content = $elem->content();
664
665 if ( $elem->isa( 'PPI::Token::QuoteLike::Command' ) ) {
666 return $content !~ m/ \A qx \s* ' /sxm;
667 }
668
669 foreach my $class ( qw{
670 PPI::Token::Quote::Double
671 PPI::Token::Quote::Interpolate
672 PPI::Token::QuoteLike::Backtick
673 PPI::Token::QuoteLike::Readline
674 } ) {
675 $elem->isa( $class ) and return $TRUE;
676 }
677
678 return $FALSE;
679}
680
681# Record a subscripted capture, either hash dereference or array
682# dereference. We assume that an array represents a numbered capture and
683# a hash represents a named capture, since we have to handle (e.g.) both
684# @+ and %+.
685sub _record_subscripted_capture {
686 my ( $variable_name, $suffix, $re, $captures, $named_captures ) = @_;
687 if ( $suffix =~ m/ \A [{] ( .*? ) [}] /smx ) {
688 ( my $name = $1 ) =~ s/ \A ( ["'] ) ( .*? ) \1 \z /$2/smx;
689 _record_named_capture( $name, $captures, $named_captures );
690 } elsif ( $suffix =~ m/ \A [[] \s* ( [-+]? \d+ ) \s* []] /smx ) {
691 _record_numbered_capture( $1 . q{}, $captures, $re );
692 }
693 return;
694}
695
696# Because a named capture is also one or more numbered captures, the recording
697# of the use of a named capture seemed complex enough to wrap in a subroutine.
698sub _record_named_capture {
699 my ( $name, $captures, $named_captures ) = @_;
700 defined ( my $numbers = $named_captures->{$name} ) or return;
701 foreach my $capnum ( @{ $numbers } ) {
702 _record_numbered_capture( $capnum, $captures );
703 }
704 $named_captures->{$name} = undef;
705 return;
706}
707
708sub _record_numbered_capture {
709 my ( $number, $captures, $re ) = @_;
710 $re and $number < 0
711 and $number = $re->max_capture_number() + $number + 1;
712 return if $number <= 0;
713 $captures->[ $number - 1 ] = 1;
714 return;
715}
716
71717┬Ás1;
718
719__END__