Profile of Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm

Filename	/Users/timbo/perl5/perlbrew/perls/perl-5.18.2/lib/site_perl/5.18.2/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm
Statements	Executed 36 statements in 2.63ms

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	16µs	16µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@10
1	1	1	8µs	12µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@12
1	1	1	8µs	38µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@14
1	1	1	8µs	27µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@17
1	1	1	8µs	26µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@20
1	1	1	8µs	67µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@25
1	1	1	8µs	136µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@16
1	1	1	8µs	27µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@18
1	1	1	7µs	376µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@15
1	1	1	7µs	415µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@21
1	1	1	7µs	18µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@11
1	1	1	6µs	7µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::default_severity
1	1	1	2µs	2µs	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::supported_parameters
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:126]
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:128]
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:193]
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:301]
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:303]
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:415]
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::__ANON__[:450]
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_block_is_slurpy
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_check_for_magic
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_check_if_in_while_condition_or_block
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_check_node_children
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_check_rest_of_statement
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_enough_assignments
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_enough_magic
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_enough_uses_in_regexp
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_has_array_sigil
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_has_hash_sigil
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_is_condition_of_if_statement
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_is_double_quotish_element
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_is_in_slurpy_array_context
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_is_preceded_by_array_or_hash_cast
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_make_regexp_checker
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_mark_magic
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_mark_magic_in_content
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_mark_magic_subscripted_code
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_record_named_capture
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_record_numbered_capture
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_record_subscripted_capture
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_skip_lhs
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::_symbol_is_slurpy
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::applies_to
0	0	0	0s	0s	Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::default_themes
0	0	0	0s	0s	Perl::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
8					package Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture;
9
10	2	39µs	1	16µ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; # spent 16µs making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@10
11	2	20µs	2	29µ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
12	2	23µs	2	15µ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
14	2	22µs	2	68µ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
15	2	28µs	2	746µ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
16	2	22µs	2	265µ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
17	2	21µs	2	46µ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
18	2	22µs	2	47µ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
20	2	24µs	2	45µ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
21	1	200ns			# 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
24	1	25µs	2	823µs	}; # spent 415µs making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture::BEGIN@21 # spent 408µs making 1 call to Exporter::import
25	2	2.34ms	2	127µ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
27	1	700ns			our $VERSION = '1.121';
28
29					#-----------------------------------------------------------------------------
30
31	1	2µs	1	32µs	Readonly::Scalar my $WHILE => q{while}; # spent 32µs making 1 call to Readonly::Scalar
32
33	1	3µs	2	27µs	Readonly::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
34	1	11µs	5	44µs	Readonly::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
38	1	1µs	1	23µs	Readonly::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
39	1	2µs	1	42µs	Readonly::Scalar my $EXPL => [252]; # spent 42µs making 1 call to Readonly::Scalar
40
41					#-----------------------------------------------------------------------------
42
43	1	5µ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() }
44	1	2µ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 }
45					sub default_themes { return qw( core pbp maintenance ) }
46					sub applies_to {
47					return qw< PPI::Token::Regexp::Match PPI::Token::Regexp::Substitute >
48					}
49
50					#-----------------------------------------------------------------------------
51
52	1	1µs	1	20µs	Readonly::Scalar my $NUM_CAPTURES_FOR_GLOBAL => 100; # arbitrarily large number # spent 20µs making 1 call to Readonly::Scalar
53
54					sub 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.
101					sub _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
131					sub _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
196					sub _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
205					sub _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
211					sub _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
217					sub _block_is_slurpy {
218					my ($block) = @_;
219
220					return $TRUE if _is_preceded_by_array_or_hash_cast($block);
221					return;
222					}
223
224					sub _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
237					sub _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
287					sub _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
296					sub _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
307					sub _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'
344					sub _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.
368	2	2µs	1	38µ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.
469					sub _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
499	2	2µs	2	22µ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.
537					sub _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
556					sub _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.
607					sub _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.
624					sub _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.
658					sub _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 %+.
685					sub _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.
698					sub _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
708					sub _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
717	1	7µs			1;
718
719					__END__