← 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/ProhibitCaptureWithoutTest.pm
StatementsExecuted 20 statements in 1.15ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11116µs16µsPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::BEGIN@10Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@10
11110µs31µsPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::BEGIN@13Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@13
1118µs11µsPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::BEGIN@12Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@12
1117µs60µsPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::BEGIN@16Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@16
1117µs234µsPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::BEGIN@15Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@15
1117µs18µsPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::BEGIN@11Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@11
1116µs6µsPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::supported_parametersPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::supported_parameters
1116µs7µsPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::default_severityPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::default_severity
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::__ANON__[:179]Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::__ANON__[:179]
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::_find_exposed_match_or_substitutePerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::_find_exposed_match_or_substitute
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::_get_method_namePerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::_get_method_name
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::_is_control_transfer_to_leftPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::_is_control_transfer_to_left
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::_is_control_transfer_to_rightPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::_is_control_transfer_to_right
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::_is_in_conditional_expressionPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::_is_in_conditional_expression
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::_is_in_conditional_structurePerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::_is_in_conditional_structure
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::_unambiguous_control_transferPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::_unambiguous_control_transfer
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::_unambiguous_gotoPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::_unambiguous_goto
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::applies_toPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::applies_to
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::default_themesPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::default_themes
0000s0sPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::::violatesPerl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::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::ProhibitCaptureWithoutTest;
9
10243µs116µs
# spent 16µs within Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::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::ProhibitCaptureWithoutTest::BEGIN@10
11220µs228µs
# spent 18µs (7+11) within Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::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::ProhibitCaptureWithoutTest::BEGIN@11 # spent 11µs making 1 call to strict::import
12218µs215µs
# spent 11µs (8+4) within Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@12 which was called: # once (8µs+4µs) by Module::Pluggable::Object::_require at line 12
use warnings;
# spent 11µs making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@12 # spent 4µs making 1 call to warnings::import
13223µs251µs
# spent 31µs (10+20) within Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@13 which was called: # once (10µs+20µs) by Module::Pluggable::Object::_require at line 13
use Readonly;
# spent 31µs making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@13 # spent 20µs making 1 call to Exporter::import
14
15224µs2460µs
# spent 234µs (7+226) within Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@15 which was called: # once (7µs+226µs) by Module::Pluggable::Object::_require at line 15
use Perl::Critic::Utils qw{ :booleans :data_conversion :severities };
# spent 234µs making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@15 # spent 226µs making 1 call to Exporter::import
1621000µs2112µs
# spent 60µs (7+52) within Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@16 which was called: # once (7µs+52µs) by Module::Pluggable::Object::_require at line 16
use base 'Perl::Critic::Policy';
# spent 60µs making 1 call to Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::BEGIN@16 # spent 52µs making 1 call to base::import
17
181600nsour $VERSION = '1.121';
19
20#-----------------------------------------------------------------------------
21
2214µs236µsReadonly::Hash my %CONDITIONAL_OPERATOR => hashify( qw{ && || ? and or xor } );
# spent 31µs making 1 call to Readonly::Hash # spent 4µs making 1 call to Perl::Critic::Utils::hashify
2312µs226µsReadonly::Hash my %UNAMBIGUOUS_CONTROL_TRANSFER => hashify(
# spent 23µs making 1 call to Readonly::Hash # spent 3µs making 1 call to Perl::Critic::Utils::hashify
24 qw< next last redo return > );
25
2611µs123µsReadonly::Scalar my $DESC => q{Capture variable used outside conditional};
# spent 23µs making 1 call to Readonly::Scalar
2712µs141µsReadonly::Scalar my $EXPL => [ 253 ];
# spent 41µs making 1 call to Readonly::Scalar
28
29#-----------------------------------------------------------------------------
30
31
# spent 6µs within Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::supported_parameters which was called: # once (6µs+0s) by Perl::Critic::Policy::new at line 88 of Perl/Critic/Policy.pm
sub supported_parameters { return (
32 {
3318µs name => 'exception_source',
34 description => 'Names of ways to generate exceptions',
35 behavior => 'string list',
36 list_always_present_values => [ qw{ die croak confess } ],
37 }
38 );
39}
4012µs
# spent 7µs (6+1) within Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest::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 }
41sub default_themes { return qw(core pbp maintenance certrule ) }
42sub applies_to { return 'PPI::Token::Magic' }
43
44#-----------------------------------------------------------------------------
45
46sub violates {
47 my ($self, $elem, $doc) = @_;
48 # TODO named capture variables
49 return if $elem !~ m/\A \$[1-9] \z/xms;
50 return if _is_in_conditional_expression($elem);
51 return if $self->_is_in_conditional_structure($elem);
52 return $self->violation( $DESC, $EXPL, $elem );
53}
54
55sub _is_in_conditional_expression {
56 my $elem = shift;
57
58 # simplistic check: is there a conditional operator between a match and
59 # the capture var?
60 my $psib = $elem->sprevious_sibling;
61 while ($psib) {
62 if ($psib->isa('PPI::Token::Operator')) {
63 my $op = $psib->content;
64 if ( $CONDITIONAL_OPERATOR{ $op } ) {
65 $psib = $psib->sprevious_sibling;
66 while ($psib) {
67 return 1 if ($psib->isa('PPI::Token::Regexp::Match'));
68 return 1 if ($psib->isa('PPI::Token::Regexp::Substitute'));
69 $psib = $psib->sprevious_sibling;
70 }
71 return; # false
72 }
73 }
74 $psib = $psib->sprevious_sibling;
75 }
76
77 return; # false
78}
79
80sub _is_in_conditional_structure {
81 my ( $self, $elem ) = @_;
82
83 my $stmt = $elem->statement();
84 while ($stmt && $elem->isa('PPI::Statement::Expression')) {
85 #return if _is_in_conditional_expression($stmt);
86 $stmt = $stmt->statement();
87 }
88 return if !$stmt;
89
90 # Check if any previous statements in the same scope have regexp matches
91 my $psib = $stmt->sprevious_sibling;
92 while ($psib) {
93 if ( $psib->isa( 'PPI::Node' ) and
94 my $match = _find_exposed_match_or_substitute( $psib ) ) {
95 return _is_control_transfer_to_left( $self, $match, $elem ) ||
96 _is_control_transfer_to_right( $self, $match, $elem );
97 }
98 $psib = $psib->sprevious_sibling;
99 }
100
101 # Check for an enclosing 'if', 'unless', 'elsif', 'else', or 'when'
102 my $parent = $stmt->parent;
103 while ($parent) { # never false as long as we're inside a PPI::Document
104 if ($parent->isa('PPI::Statement::Compound') ||
105 $parent->isa('PPI::Statement::When' )
106 ) {
107 return 1;
108 }
109 elsif ($parent->isa('PPI::Structure')) {
110 return 1 if _is_in_conditional_expression($parent);
111 return 1 if $self->_is_in_conditional_structure($parent);
112 $parent = $parent->parent;
113 }
114 else {
115 last;
116 }
117 }
118
119 return; # fail
120}
121
122# This subroutine returns true if there is a control transfer to the left of
123# the match operation which would bypass the capture variable. The arguments
124# are the match operation and the capture variable.
125sub _is_control_transfer_to_left {
126 my ( $self, $match, $elem ) = @_;
127 # If a regexp match is found, we succeed if a match failure
128 # appears to throw an exception, and fail otherwise. RT 36081
129 my $prev = $match->sprevious_sibling() or return;
130 while ( not ( $prev->isa( 'PPI::Token::Word' ) &&
131 q<unless> eq $prev->content() ) ) {
132 $prev = $prev->sprevious_sibling() or return;
133 }
134 # In this case we analyze the first thing to appear in the parent of the
135 # 'unless'. This is the simplest case, and it will not be hard to dream up
136 # cases where this is insufficient (e.g. do {something(); die} unless ...)
137 my $parent = $prev->parent() or return;
138 my $first = $parent->schild( 0 ) or return;
139 if ( my $method = _get_method_name( $first ) ) {
140 # Methods can also be exception sources.
141 return $self->{_exception_source}{ $method->content() };
142 }
143 return $self->{_exception_source}{ $first->content() } ||
144 _unambiguous_control_transfer( $first, $elem );
145}
146
147# This subroutine returns true if there is a control transfer to the right of
148# the match operation which would bypass the capture variable. The arguments
149# are the match operation and the capture variable.
150sub _is_control_transfer_to_right {
151 my ( $self, $match, $elem ) = @_;
152 # If a regexp match is found, we succeed if a match failure
153 # appears to throw an exception, and fail otherwise. RT 36081
154 my $oper = $match->snext_sibling() or return; # fail
155 my $oper_content = $oper->content();
156 # We do not check 'dor' or '//' because a match failure does not
157 # return an undefined value.
158 q{or} eq $oper_content
159 or q{||} eq $oper_content
160 or return; # fail
161 my $next = $oper->snext_sibling() or return; # fail
162 if ( my $method = _get_method_name( $next ) ) {
163 # Methods can also be exception sources.
164 return $self->{_exception_source}{ $method->content() };
165 }
166 return $self->{_exception_source}{ $next->content() } ||
167 _unambiguous_control_transfer( $next, $elem );
168}
169
170# Given a PPI::Node, find the last regexp match or substitution that is
171# in-scope to the node's next sibling.
172sub _find_exposed_match_or_substitute { # RT 36081
173 my $elem = shift;
174FIND_REGEXP_NOT_IN_BLOCK:
175 foreach my $regexp ( reverse @{ $elem->find(
176 sub {
177 return $_[1]->isa( 'PPI::Token::Regexp::Substitute' )
178 || $_[1]->isa( 'PPI::Token::Regexp::Match' );
179 }
180 ) || [] } ) {
181 my $parent = $regexp->parent();
182 while ( $parent != $elem ) {
183 $parent->isa( 'PPI::Structure::Block' )
184 and next FIND_REGEXP_NOT_IN_BLOCK;
185 $parent = $parent->parent()
186 or next FIND_REGEXP_NOT_IN_BLOCK;
187 }
188 return $regexp;
189 }
190 return;
191}
192
193# If the argument introduces a method call, return the method name;
194# otherwise just return.
195sub _get_method_name {
196 my ( $elem ) = @_;
197 # We fail unless the element we were given looks like it might be an
198 # object or a class name.
199 $elem or return;
200 (
201 $elem->isa( 'PPI::Token::Symbol' ) &&
202 q<$> eq $elem->raw_type() ||
203 $elem->isa( 'PPI::Token::Word' ) &&
204 $elem->content() =~ m/ \A [\w:]+ \z /smx
205 ) or return;
206 # We skip over all the subscripts and '->' operators to the right of
207 # the original element, failing if we run out of objects.
208 my $prior;
209 my $next = $elem->snext_sibling() or return;
210 while ( $next->isa( 'PPI::Token::Subscript' ) ||
211 $next->isa( 'PPI::Token::Operator' ) &&
212 q{->} eq $next->content() ) {
213 $prior = $next;
214 $next = $next->snext_sibling or return; # fail
215 }
216 # A method call must have a '->' operator before it.
217 ( $prior &&
218 $prior->isa( 'PPI::Token::Operator' ) &&
219 q{->} eq $prior->content()
220 ) or return;
221 # Anything other than a PPI::Token::Word can not be statically
222 # recognized as a method name.
223 $next->isa( 'PPI::Token::Word' ) or return;
224 # Whatever we have left at this point looks very like a method name.
225 return $next;
226}
227
228# Determine whether the given element represents an unambiguous transfer of
229# control around anything that follows it in the same block. The arguments are
230# the element to check, and the capture variable that is the subject of this
231# call to the policy.
232sub _unambiguous_control_transfer { # RT 36081.
233 my ( $xfer, $elem ) = @_;
234
235 my $content = $xfer->content();
236
237 # Anything in the hash is always a transfer of control.
238 return $TRUE if $UNAMBIGUOUS_CONTROL_TRANSFER{ $content };
239
240 # A goto is not unambiguous on the face of it, but at least some forms of
241 # it can be accepted.
242 q<goto> eq $content
243 and return _unambiguous_goto( $xfer, $elem );
244
245 # Anything left at this point is _not_ an unambiguous transfer of control
246 # around whatever follows it.
247 return;
248}
249
250# Determine whether the given goto represents an unambiguous transfer of
251# control around anything that follows it in the same block. The arguments are
252# the element to check, and the capture variable that is the subject of this
253# call to the policy.
254sub _unambiguous_goto {
255 my ( $xfer, $elem ) = @_;
256
257 # A goto without a target?
258 my $target = $xfer->snext_sibling() or return;
259
260 # The co-routine form of goto is an unambiguous transfer of control.
261 $target->isa( 'PPI::Token::Symbol' )
262 and q<&> eq $target->raw_type()
263 and return $TRUE;
264
265 # The label form of goto is an unambiguous transfer of control,
266 # provided the label does not occur between the goto and the capture
267 # variable.
268 if ( $target->isa( 'PPI::Token::Word' ) ) {
269
270 # We need to search in our most-local block, or the document if
271 # there is no enclosing block.
272 my $container = $target;
273 while ( my $parent = $container->parent() ) {
274 $container = $parent;
275 $container->isa( 'PPI::Structure::Block' ) and last;
276 }
277
278 # We search the container for our label. If we find it, we return
279 # true if it occurs before the goto or after the capture variable,
280 # otherwise we return false. If we do not find it we return true.
281 # Note that perl does not seem to consider duplicate labels an
282 # error, but also seems to take the first one in the relevant
283 # scope when this happens.
284 my $looking_for = qr/ \A @{[ $target->content() ]} \s* : \z /smx;
285 my ($start_line, $start_char) = @{ $xfer->location() || [] };
286 defined $start_line or return; # document not indexed.
287 my ($end_line, $end_char) = @{ $elem->location() || [] };
288 foreach my $label (
289 @{ $container->find( 'PPI::Token::Label' ) || [] } )
290 {
291 $label->content() =~ m/$looking_for/smx or next;
292 my ( $line, $char ) = @{ $label->location() || [] };
293 return $TRUE
294 if $line < $start_line ||
295 $line == $start_line && $char < $start_char;
296 return $TRUE
297 if $line > $end_line ||
298 $line == $end_line && $char > $end_char;
299 return;
300 }
301 return $TRUE;
302 }
303
304 # Any other form of goto can not be statically analyzed, and so is not
305 # an unambiguous transfer of control around the capture variable.
306 return;
307}
308
30916µs1;
310
311#-----------------------------------------------------------------------------
312
313__END__
Report produced by the NYTProf 6.01 Perl profiler, developed by Tim Bunce and Adam Kaplan.