← 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:12 2016

Filename/Users/timbo/perl5/perlbrew/perls/perl-5.18.2/lib/site_perl/5.18.2/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm
StatementsExecuted 22 statements in 1.21ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11117µs81µsPerl::Critic::Policy::ErrorHandling::RequireCarping::::BEGIN@19Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@19
11116µs16µsPerl::Critic::Policy::ErrorHandling::RequireCarping::::BEGIN@10Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@10
11110µs31µsPerl::Critic::Policy::ErrorHandling::RequireCarping::::BEGIN@18Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@18
1119µs12µsPerl::Critic::Policy::ErrorHandling::RequireCarping::::default_severityPerl::Critic::Policy::ErrorHandling::RequireCarping::default_severity
1119µs9µsPerl::Critic::Policy::ErrorHandling::RequireCarping::::supported_parametersPerl::Critic::Policy::ErrorHandling::RequireCarping::supported_parameters
1117µs666µsPerl::Critic::Policy::ErrorHandling::RequireCarping::::BEGIN@15Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@15
1117µs18µsPerl::Critic::Policy::ErrorHandling::RequireCarping::::BEGIN@11Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@11
1117µs10µsPerl::Critic::Policy::ErrorHandling::RequireCarping::::BEGIN@12Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@12
1117µs27µsPerl::Critic::Policy::ErrorHandling::RequireCarping::::BEGIN@13Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@13
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::_determine_if_list_is_a_plain_list_and_get_last_childPerl::Critic::Policy::ErrorHandling::RequireCarping::_determine_if_list_is_a_plain_list_and_get_last_child
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::_find_last_element_in_subexpressionPerl::Critic::Policy::ErrorHandling::RequireCarping::_find_last_element_in_subexpression
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::_find_last_flattened_argument_list_elementPerl::Critic::Policy::ErrorHandling::RequireCarping::_find_last_flattened_argument_list_element
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::_is_complex_expression_tokenPerl::Critic::Policy::ErrorHandling::RequireCarping::_is_complex_expression_token
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::_is_element_contained_in_subroutinePerl::Critic::Policy::ErrorHandling::RequireCarping::_is_element_contained_in_subroutine
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::_is_element_in_namespace_mainPerl::Critic::Policy::ErrorHandling::RequireCarping::_is_element_in_namespace_main
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::_is_postfix_operatorPerl::Critic::Policy::ErrorHandling::RequireCarping::_is_postfix_operator
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::_is_simple_list_element_tokenPerl::Critic::Policy::ErrorHandling::RequireCarping::_is_simple_list_element_token
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::_last_flattened_argument_list_element_ends_in_newlinePerl::Critic::Policy::ErrorHandling::RequireCarping::_last_flattened_argument_list_element_ends_in_newline
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::applies_toPerl::Critic::Policy::ErrorHandling::RequireCarping::applies_to
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::default_themesPerl::Critic::Policy::ErrorHandling::RequireCarping::default_themes
0000s0sPerl::Critic::Policy::ErrorHandling::RequireCarping::::violatesPerl::Critic::Policy::ErrorHandling::RequireCarping::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::ErrorHandling::RequireCarping;
9
10242µs116µs
# spent 16µs within Perl::Critic::Policy::ErrorHandling::RequireCarping::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::ErrorHandling::RequireCarping::BEGIN@10
11219µs229µs
# spent 18µs (7+11) within Perl::Critic::Policy::ErrorHandling::RequireCarping::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::ErrorHandling::RequireCarping::BEGIN@11 # spent 11µs making 1 call to strict::import
12217µs214µs
# spent 10µs (7+4) within Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@12 which was called: # once (7µs+4µs) by Module::Pluggable::Object::_require at line 12
use warnings;
# spent 10µs making 1 call to Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@12 # spent 4µs making 1 call to warnings::import
13224µs247µs
# spent 27µs (7+20) within Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@13 which was called: # once (7µs+20µs) by Module::Pluggable::Object::_require at line 13
use Readonly;
# spent 27µs making 1 call to Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@13 # spent 20µs making 1 call to Exporter::import
14
151200ns
# spent 666µs (7+659) within Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@15 which was called: # once (7µs+659µs) by Module::Pluggable::Object::_require at line 17
use Perl::Critic::Utils qw{
16 :booleans :characters :severities :classification :data_conversion
17125µs21.32ms};
# spent 666µs making 1 call to Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@15 # spent 659µs making 1 call to Exporter::import
18223µs252µs
# spent 31µs (10+22) within Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@18 which was called: # once (10µs+22µs) by Module::Pluggable::Object::_require at line 18
use Perl::Critic::Utils::PPI qw{ is_ppi_expression_or_generic_statement };
# spent 31µs making 1 call to Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@18 # spent 22µs making 1 call to Exporter::import
1921.02ms2146µs
# spent 81µs (17+64) within Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@19 which was called: # once (17µs+64µs) by Module::Pluggable::Object::_require at line 19
use base 'Perl::Critic::Policy';
# spent 81µs making 1 call to Perl::Critic::Policy::ErrorHandling::RequireCarping::BEGIN@19 # spent 64µs making 1 call to base::import
20
211800nsour $VERSION = '1.121';
22
23#-----------------------------------------------------------------------------
24
2514µs166µsReadonly::Scalar my $EXPL => [ 283 ];
# spent 66µs making 1 call to Readonly::Scalar
26
27#-----------------------------------------------------------------------------
28
29
# spent 9µs within Perl::Critic::Policy::ErrorHandling::RequireCarping::supported_parameters which was called: # once (9µs+0s) by Perl::Critic::Policy::new at line 88 of Perl/Critic/Policy.pm
sub supported_parameters {
30 return (
31 {
32112µs name => 'allow_messages_ending_with_newlines',
33 description => q{Don't complain about die or warn if the message ends in a newline.},
34 default_string => '1',
35 behavior => 'boolean',
36 },
37 {
38 name => 'allow_in_main_unless_in_subroutine',
39 description => q{Don't complain about die or warn in main::, unless in a subroutine.},
40 default_string => '0',
41 behavior => 'boolean',
42 },
43 );
44}
45
4612µs
# spent 12µs (9+2) within Perl::Critic::Policy::ErrorHandling::RequireCarping::default_severity which was called: # once (9µs+2µs) by Perl::Critic::Policy::get_severity at line 331 of Perl/Critic/Policy.pm
sub default_severity { return $SEVERITY_MEDIUM }
47sub default_themes { return qw( core pbp maintenance certrule ) }
48sub applies_to { return 'PPI::Token::Word' }
49
50#-----------------------------------------------------------------------------
51
52sub violates {
53 my ( $self, $elem, undef ) = @_;
54
55 my $alternative;
56 if ( $elem eq 'warn' ) {
57 $alternative = 'carp';
58 }
59 elsif ( $elem eq 'die' ) {
60 $alternative = 'croak';
61 }
62 else {
63 return;
64 }
65
66 return if ! is_function_call($elem);
67
68 if ($self->{_allow_messages_ending_with_newlines}) {
69 return if _last_flattened_argument_list_element_ends_in_newline($elem);
70 }
71
72 return if $self->{_allow_in_main_unless_in_subroutine}
73 && !$self->_is_element_contained_in_subroutine( $elem )
74 && $self->_is_element_in_namespace_main( $elem ); # RT #56619
75
76 my $desc = qq{"$elem" used instead of "$alternative"};
77 return $self->violation( $desc, $EXPL, $elem );
78}
79
80#-----------------------------------------------------------------------------
81
82sub _last_flattened_argument_list_element_ends_in_newline {
83 my $die_or_warn = shift;
84
85 my $last_flattened_argument =
86 _find_last_flattened_argument_list_element($die_or_warn)
87 or return $FALSE;
88
89 if ( $last_flattened_argument->isa('PPI::Token::Quote') ) {
90 my $last_flattened_argument_string =
91 $last_flattened_argument->string();
92 if (
93 $last_flattened_argument_string =~ m{ \n \z }xms
94 or (
95 (
96 $last_flattened_argument->isa('PPI::Token::Quote::Double')
97 or $last_flattened_argument->isa('PPI::Token::Quote::Interpolate')
98 )
99 and $last_flattened_argument_string =~ m{ [\\] n \z }xms
100 )
101 ) {
102 return $TRUE;
103 }
104 }
105 elsif ( $last_flattened_argument->isa('PPI::Token::HereDoc') ) {
106 return $TRUE;
107 }
108
109 return $FALSE
110}
111
112#-----------------------------------------------------------------------------
113# Here starts the fun. Explanation by example:
114#
115# Let's say we've got the following (contrived) statement:
116#
117# die q{Isn't }, ( $this, ( " fun?\n" ) , ) if "It isn't Monday.";
118#
119# This statement should pass because the last parameter that die is going to
120# get is C<" fun?\n">.
121#
122# The approach is to first find the last non-flattened parameter. If this
123# is a simple token, we're done. Else, it's some aggregate thing. We can't
124# tell what C<some_function( "foo\n" )> is going to do, so we give up on
125# anything other than a PPI::Structure::List.
126#
127# There are three possible scenarios for the children of a List:
128#
129# * No children of the List, i.e. the list looks like C< ( ) >.
130# * One PPI::Statement::Expression element.
131# * One PPI::Statement element. That's right, an instance of the base
132# statement class and not some subclass. *sigh*
133#
134# In the first case, we're done. The latter two cases get treated
135# identically. We get the last child of the Statement and start the search
136# all over again.
137#
138# Back to our example. The PPI tree for this expression is
139#
140# PPI::Document
141# PPI::Statement
142# PPI::Token::Word 'die'
143# PPI::Token::Quote::Literal 'q{Isn't }'
144# PPI::Token::Operator ','
145# PPI::Structure::List ( ... )
146# PPI::Statement::Expression
147# PPI::Token::Symbol '$this'
148# PPI::Token::Operator ','
149# PPI::Structure::List ( ... )
150# PPI::Statement::Expression
151# PPI::Token::Quote::Double '" fun?\n"'
152# PPI::Token::Operator ','
153# PPI::Token::Word 'if'
154# PPI::Token::Quote::Double '"It isn't Monday.\n"'
155# PPI::Token::Structure ';'
156#
157# We're starting with the Word containing 'die' (it could just as well be
158# 'warn') because the earlier parts of validate() have taken care of any
159# other possibility. We're going to scan forward through 'die's siblings
160# until we reach what we think the end of its parameters are. So we get
161#
162# 1. A Literal. A perfectly good argument.
163# 2. A comma operator. Looks like we've got more to go.
164# 3. A List. Another argument.
165# 4. The Word 'if'. Oops. That's a postfix operator.
166#
167# Thus, the last parameter is the List. So, we've got to scan backwards
168# through the components of the List; again, the goal is to find the last
169# value in the flattened list.
170#
171# Before decending into the List, we check that it isn't a subroutine call by
172# looking at its prior sibling. In this case, the prior sibling is a comma
173# operator, so it's fine.
174#
175# The List has one Expression element as we expect. We grab the Expression's
176# last child and start all over again.
177#
178# 1. The last child is a comma operator, which Perl will ignore, so we
179# skip it.
180# 2. The comma's prior sibling is a List. This is the last significant
181# part of the outer list.
182# 3. The List's prior sibling isn't a Word, so we can continue because the
183# List is not a parameter list.
184# 4. We go through the child Expression and find that the last child of
185# that is a PPI::Token::Quote::Double, which is a simple, non-compound
186# token. We return that and we're done.
187
188sub _find_last_flattened_argument_list_element {
189 my $die_or_warn = shift;
190
191 # Zoom forward...
192 my $current_candidate =
193 _find_last_element_in_subexpression($die_or_warn);
194
195 # ... scan back.
196 while (
197 $current_candidate
198 and not _is_simple_list_element_token( $current_candidate )
199 and not _is_complex_expression_token( $current_candidate )
200 ) {
201 if ( $current_candidate->isa('PPI::Structure::List') ) {
202 $current_candidate =
203 _determine_if_list_is_a_plain_list_and_get_last_child(
204 $current_candidate,
205 $die_or_warn
206 );
207 } elsif ( not $current_candidate->isa('PPI::Token') ) {
208 return;
209 } else {
210 $current_candidate = $current_candidate->sprevious_sibling();
211 }
212 }
213
214 return if not $current_candidate;
215 return if _is_complex_expression_token( $current_candidate );
216
217 my $penultimate_element = $current_candidate->sprevious_sibling();
218 if ($penultimate_element) {
219 # Bail if we've got a Word in front of the Element that isn't
220 # the original 'die' or 'warn' or anything else that isn't
221 # a comma or dot operator.
222 if ( $penultimate_element->isa('PPI::Token::Operator') ) {
223 if (
224 $penultimate_element ne $COMMA
225 and $penultimate_element ne $PERIOD
226 ) {
227 return;
228 }
229 } elsif ( $penultimate_element != $die_or_warn ) {
230 return
231 }
232 }
233
234 return $current_candidate;
235}
236
237#-----------------------------------------------------------------------------
238# This is the part where we scan forward from the 'die' or 'warn' to find
239# the last argument.
240
241sub _find_last_element_in_subexpression {
242 my $die_or_warn = shift;
243
244 my $last_following_sibling;
245 my $next_sibling = $die_or_warn;
246 while (
247 $next_sibling = $next_sibling->snext_sibling()
248 and not _is_postfix_operator( $next_sibling )
249 ) {
250 $last_following_sibling = $next_sibling;
251 }
252
253 return $last_following_sibling;
254}
255
256#-----------------------------------------------------------------------------
257# Ensure that the list isn't a parameter list. Find the last element of it.
258
259sub _determine_if_list_is_a_plain_list_and_get_last_child {
260 my ($list, $die_or_warn) = @_;
261
262 my $prior_sibling = $list->sprevious_sibling();
263
264 if ( $prior_sibling ) {
265 # Bail if we've got a Word in front of the List that isn't
266 # the original 'die' or 'warn' or anything else that isn't
267 # a comma operator.
268 if ( $prior_sibling->isa('PPI::Token::Operator') ) {
269 if ( $prior_sibling ne $COMMA ) {
270 return;
271 }
272 } elsif ( $prior_sibling != $die_or_warn ) {
273 return
274 }
275 }
276
277 my @list_children = $list->schildren();
278
279 # If zero children, nothing to look for.
280 # If multiple children, then PPI is not giving us
281 # anything we understand.
282 return if scalar (@list_children) != 1;
283
284 my $list_child = $list_children[0];
285
286 # If the child isn't an Expression or it is some other subclass
287 # of Statement, we again don't understand PPI's output.
288 return if not is_ppi_expression_or_generic_statement($list_child);
289
290 my @statement_children = $list_child->schildren();
291 return if scalar (@statement_children) < 1;
292
293 return $statement_children[-1];
294}
295
296
297#-----------------------------------------------------------------------------
29814µs239µsReadonly::Hash my %POSTFIX_OPERATORS =>
# spent 34µs making 1 call to Readonly::Hash # spent 4µs making 1 call to Perl::Critic::Utils::hashify
299 hashify qw{ if unless while until for foreach };
300
301sub _is_postfix_operator {
302 my $element = shift;
303
304 if (
305 $element->isa('PPI::Token::Word')
306 and $POSTFIX_OPERATORS{$element}
307 ) {
308 return $TRUE;
309 }
310
311 return $FALSE;
312}
313
314
31512µs128µsReadonly::Array my @SIMPLE_LIST_ELEMENT_TOKEN_CLASSES =>
# spent 28µs making 1 call to Readonly::Array
316 qw{
317 PPI::Token::Number
318 PPI::Token::Word
319 PPI::Token::DashedWord
320 PPI::Token::Symbol
321 PPI::Token::Quote
322 PPI::Token::HereDoc
323 };
324
325sub _is_simple_list_element_token {
326 my $element = shift;
327
328 return $FALSE if not $element->isa('PPI::Token');
329
330 foreach my $class (@SIMPLE_LIST_ELEMENT_TOKEN_CLASSES) {
331 return $TRUE if $element->isa($class);
332 }
333
334 return $FALSE;
335}
336
337
338#-----------------------------------------------------------------------------
339# Tokens that can't possibly be part of an expression simple
340# enough for us to examine.
341
34212µs130µsReadonly::Array my @COMPLEX_EXPRESSION_TOKEN_CLASSES =>
# spent 30µs making 1 call to Readonly::Array
343 qw{
344 PPI::Token::ArrayIndex
345 PPI::Token::QuoteLike
346 PPI::Token::Regexp
347 PPI::Token::Cast
348 PPI::Token::Label
349 PPI::Token::Separator
350 PPI::Token::Data
351 PPI::Token::End
352 PPI::Token::Prototype
353 PPI::Token::Attribute
354 PPI::Token::Unknown
355 };
356
357sub _is_complex_expression_token {
358 my $element = shift;
359
360 return $FALSE if not $element->isa('PPI::Token');
361
362 foreach my $class (@COMPLEX_EXPRESSION_TOKEN_CLASSES) {
363 return $TRUE if $element->isa($class);
364 }
365
366 return $FALSE;
367}
368
369#-----------------------------------------------------------------------------
370# Check whether the given element is contained in a subroutine.
371
372sub _is_element_contained_in_subroutine {
373 my ( $self, $elem ) = @_;
374
375 my $parent = $elem;
376 while ( $parent = $parent->parent() ) {
377 $parent->isa( 'PPI::Statement::Sub' ) and return $TRUE;
378 $parent->isa( 'PPI::Structure::Block' ) or next;
379 my $prior_elem = $parent->sprevious_sibling() or next;
380 $prior_elem->isa( 'PPI::Token::Word' )
381 and 'sub' eq $prior_elem->content()
382 and return $TRUE;
383 }
384
385 return $FALSE;
386}
387
388#-----------------------------------------------------------------------------
389# Check whether the given element is in main::
390
391sub _is_element_in_namespace_main {
392 my ( $self, $elem ) = @_;
393 my $current_elem = $elem;
394 my $prior_elem;
395
396 while ( $current_elem ) {
397 while ( $prior_elem = $current_elem->sprevious_sibling() ) {
398 if ( $prior_elem->isa( 'PPI::Statement::Package' ) ) {
399 return 'main' eq $prior_elem->namespace();
400 }
401 } continue {
402 $current_elem = $prior_elem;
403 }
404 $current_elem = $current_elem->parent();
405 }
406
407 return $TRUE;
408}
409
41019µs1;
411
412__END__
Report produced by the NYTProf 6.01 Perl profiler, developed by Tim Bunce and Adam Kaplan.