← 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/Subroutines/RequireArgUnpacking.pm
StatementsExecuted 38 statements in 1.30ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11117µs19µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::supported_parametersPerl::Critic::Policy::Subroutines::RequireArgUnpacking::supported_parameters
11116µs16µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@10Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@10
11116µs64µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@25Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@25
11112µs31µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@16Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@16
11111µs36µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@19Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@19
11110µs11µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::default_severityPerl::Critic::Policy::Subroutines::RequireArgUnpacking::default_severity
1118µs19µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@11Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@11
1118µs426µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@22Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@22
1118µs42µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@14Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@14
1118µs11µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@12Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@12
1117µs377µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@15Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@15
1117µs187µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@20Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@20
1115µs5µsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::BEGIN@18Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@18
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::_get_arg_symbolsPerl::Critic::Policy::Subroutines::RequireArgUnpacking::_get_arg_symbols
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::_is_cast_of_arrayPerl::Critic::Policy::Subroutines::RequireArgUnpacking::_is_cast_of_array
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::_is_cast_of_scalarPerl::Critic::Policy::Subroutines::RequireArgUnpacking::_is_cast_of_scalar
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::_is_delegationPerl::Critic::Policy::Subroutines::RequireArgUnpacking::_is_delegation
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::_is_postfix_foreachPerl::Critic::Policy::Subroutines::RequireArgUnpacking::_is_postfix_foreach
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::_is_size_checkPerl::Critic::Policy::Subroutines::RequireArgUnpacking::_is_size_check
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::_is_unpackPerl::Critic::Policy::Subroutines::RequireArgUnpacking::_is_unpack
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::_legal_after_size_checkPerl::Critic::Policy::Subroutines::RequireArgUnpacking::_legal_after_size_check
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::_legal_before_size_checkPerl::Critic::Policy::Subroutines::RequireArgUnpacking::_legal_before_size_check
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::_magic_finderPerl::Critic::Policy::Subroutines::RequireArgUnpacking::_magic_finder
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::applies_toPerl::Critic::Policy::Subroutines::RequireArgUnpacking::applies_to
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::default_themesPerl::Critic::Policy::Subroutines::RequireArgUnpacking::default_themes
0000s0sPerl::Critic::Policy::Subroutines::RequireArgUnpacking::::violatesPerl::Critic::Policy::Subroutines::RequireArgUnpacking::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::Subroutines::RequireArgUnpacking;
9
10240µs116µs
# spent 16µs within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::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::Subroutines::RequireArgUnpacking::BEGIN@10
11220µs231µs
# spent 19µs (8+11) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@11 which was called: # once (8µs+11µs) by Module::Pluggable::Object::_require at line 11
use strict;
# spent 19µs making 1 call to Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@11 # spent 11µs making 1 call to strict::import
12218µs215µs
# spent 11µs (8+4) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::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::Subroutines::RequireArgUnpacking::BEGIN@12 # spent 4µs making 1 call to warnings::import
13
14222µs275µs
# spent 42µs (8+34) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@14 which was called: # once (8µs+34µs) by Module::Pluggable::Object::_require at line 14
use Carp;
# spent 42µs making 1 call to Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@14 # spent 34µs making 1 call to Exporter::import
15222µs2747µs
# spent 377µs (7+370) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@15 which was called: # once (7µs+370µs) by Module::Pluggable::Object::_require at line 15
use English qw(-no_match_vars);
# spent 377µs making 1 call to Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@15 # spent 370µs making 1 call to English::import
16221µs250µs
# spent 31µs (12+19) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@16 which was called: # once (12µs+19µs) by Module::Pluggable::Object::_require at line 16
use Readonly;
# spent 31µs making 1 call to Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@16 # spent 19µs making 1 call to Exporter::import
17
18220µs15µs
# spent 5µs within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@18 which was called: # once (5µs+0s) by Module::Pluggable::Object::_require at line 18
use File::Spec;
# spent 5µs making 1 call to Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@18
19222µs243µs
# spent 36µs (11+25) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@19 which was called: # once (11µs+25µs) by Module::Pluggable::Object::_require at line 19
use List::Util qw(first);
# spent 36µs making 1 call to Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@19 # spent 8µs making 1 call to List::Util::import
20226µs2366µs
# spent 187µs (7+179) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@20 which was called: # once (7µs+179µs) by Module::Pluggable::Object::_require at line 20
use List::MoreUtils qw(uniq any);
# spent 187µs making 1 call to Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@20 # spent 179µs making 1 call to Exporter::Tiny::import
21
221200ns
# spent 426µs (8+419) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@22 which was called: # once (8µs+419µs) by Module::Pluggable::Object::_require at line 24
use Perl::Critic::Utils qw<
23 :booleans :characters hashify :severities words_from_string
24133µs2845µs>;
# spent 426µs making 1 call to Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@22 # spent 418µs making 1 call to Exporter::import
2521.01ms2112µs
# spent 64µs (16+48) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@25 which was called: # once (16µs+48µs) by Module::Pluggable::Object::_require at line 25
use base 'Perl::Critic::Policy';
# spent 64µs making 1 call to Perl::Critic::Policy::Subroutines::RequireArgUnpacking::BEGIN@25 # spent 48µs making 1 call to base::import
26
271600nsour $VERSION = '1.121';
28
29#-----------------------------------------------------------------------------
30
3112µs130µsReadonly::Scalar my $AT => q{@};
# spent 30µs making 1 call to Readonly::Scalar
3211µs121µsReadonly::Scalar my $AT_ARG => q{@_}; ## no critic (InterpolationOfMetachars)
# spent 21µs making 1 call to Readonly::Scalar
331900ns120µsReadonly::Scalar my $DOLLAR => q{$};
# spent 20µs making 1 call to Readonly::Scalar
341900ns119µsReadonly::Scalar my $DOLLAR_ARG => q{$_}; ## no critic (InterpolationOfMetaChars)
# spent 19µs making 1 call to Readonly::Scalar
35
3614µs221µsReadonly::Scalar my $DESC => qq{Always unpack $AT_ARG first};
# spent 20µs making 1 call to Readonly::Scalar # spent 2µs making 1 call to Readonly::Scalar::FETCH
3712µs140µsReadonly::Scalar my $EXPL => [178];
# spent 40µs making 1 call to Readonly::Scalar
38
39#-----------------------------------------------------------------------------
40
41
# spent 19µs (17+2) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::supported_parameters which was called: # once (17µs+2µs) by Perl::Critic::Policy::new at line 88 of Perl/Critic/Policy.pm
sub supported_parameters {
42 return (
43 {
44115µs22µs name => 'short_subroutine_statements',
# spent 2µs making 2 calls to Readonly::Scalar::FETCH, avg 1µs/call
45 description =>
46 'The number of statements to allow without unpacking.',
47 default_string => '0',
48 behavior => 'integer',
49 integer_minimum => 0,
50 },
51 {
52 name => 'allow_subscripts',
53 description =>
54 'Should unpacking from array slices and elements be allowed?',
55 default_string => $FALSE,
56 behavior => 'boolean',
57 },
58 {
59 name => 'allow_delegation_to',
60 description =>
61 'Allow the usual delegation idiom to these namespaces/subroutines',
62 behavior => 'string list',
63 list_always_present_values => [ qw< SUPER:: NEXT:: > ],
64 }
65 );
66}
67
6812µs
# spent 11µs (10+1) within Perl::Critic::Policy::Subroutines::RequireArgUnpacking::default_severity which was called: # once (10µs+1µs) by Perl::Critic::Policy::get_severity at line 331 of Perl/Critic/Policy.pm
sub default_severity { return $SEVERITY_HIGH }
69sub default_themes { return qw( core pbp maintenance ) }
70sub applies_to { return 'PPI::Statement::Sub' }
71
72#-----------------------------------------------------------------------------
73
74sub violates {
75 my ( $self, $elem, undef ) = @_;
76
77 # forward declaration?
78 return if not $elem->block;
79
80 my @statements = $elem->block->schildren;
81
82 # empty sub?
83 return if not @statements;
84
85 # Don't apply policy to short subroutines
86
87 # Should we instead be doing a find() for PPI::Statement
88 # instances? That is, should we count all statements instead of
89 # just top-level statements?
90 return if $self->{_short_subroutine_statements} >= @statements;
91
92 # look for explicit dereferences of @_, including '$_[0]'
93 # You may use "... = @_;" in the first paragraph of the sub
94 # Don't descend into nested or anonymous subs
95 my $state = 'unpacking'; # still in unpacking paragraph
96 for my $statement (@statements) {
97
98 my @magic = _get_arg_symbols($statement);
99
100 my $saw_unpack = $FALSE;
101
102 MAGIC:
103 for my $magic (@magic) {
104 # allow conditional checks on the size of @_
105 next MAGIC if _is_size_check($magic);
106
107 if ('unpacking' eq $state) {
108 if ($self->_is_unpack($magic)) {
109 $saw_unpack = $TRUE;
110 next MAGIC;
111 }
112 }
113
114 # allow @$_[] construct in "... for ();"
115 # Check for "print @$_[] for ()" construct (rt39601)
116 next MAGIC
117 if _is_cast_of_array($magic) and _is_postfix_foreach($magic);
118
119 # allow $$_[], which is equivalent to $_->[] and not a use
120 # of @_ at all.
121 next MAGIC
122 if _is_cast_of_scalar( $magic );
123
124 # allow delegation of the form "$self->SUPER::foo( @_ );"
125 next MAGIC
126 if $self->_is_delegation( $magic );
127
128 # If we make it this far, it is a violation
129 return $self->violation( $DESC, $EXPL, $elem );
130 }
131 if (not $saw_unpack) {
132 $state = 'post_unpacking';
133 }
134 }
135 return; # OK
136}
137
138sub _is_unpack {
139 my ($self, $magic) = @_;
140
141 my $prev = $magic->sprevious_sibling();
142 my $next = $magic->snext_sibling();
143
144 # If we have a subscript, we're dealing with an array slice on @_
145 # or an array element of @_. See RT #34009.
146 if ( $next and $next->isa('PPI::Structure::Subscript') ) {
147 $self->{_allow_subscripts} or return;
148 $next = $next->snext_sibling;
149 }
150
151 return $TRUE if
152 $prev
153 and $prev->isa('PPI::Token::Operator')
154 and q{=} eq $prev->content()
155 and (
156 not $next
157 or $next->isa('PPI::Token::Structure')
158 and $SCOLON eq $next->content()
159 );
160 return;
161}
162
163sub _is_size_check {
164 my ($magic) = @_;
165
166 # No size check on $_[0]. RT #34009.
167 $AT eq $magic->raw_type or return;
168
169 my $prev = $magic->sprevious_sibling;
170 my $next = $magic->snext_sibling;
171
172 if ( $prev || $next ) {
173
174 return $TRUE
175 if _legal_before_size_check( $prev )
176 and _legal_after_size_check( $next );
177 }
178
179 my $parent = $magic;
180 {
181 $parent = $parent->parent()
182 or return;
183 $prev = $parent->sprevious_sibling();
184 $next = $parent->snext_sibling();
185 $prev
186 or $next
187 or redo;
188 } # until ( $prev || $next );
189
190 return $TRUE
191 if $parent->isa( 'PPI::Structure::Condition' );
192
193 return;
194}
195
196{
197
19824µs235µs Readonly::Hash my %LEGAL_NEXT_OPER => hashify(
# spent 31µs making 1 call to Readonly::Hash # spent 4µs making 1 call to Perl::Critic::Utils::hashify
199 qw{ && || == != > >= < <= and or } );
200
20112µs220µs Readonly::Hash my %LEGAL_NEXT_STRUCT => hashify( qw{ ; } );
# spent 18µs making 1 call to Readonly::Hash # spent 2µs making 1 call to Perl::Critic::Utils::hashify
202
203 sub _legal_after_size_check {
204 my ( $next ) = @_;
205
206 $next
207 or return $TRUE;
208
209 $next->isa( 'PPI::Token::Operator' )
210 and return $LEGAL_NEXT_OPER{ $next->content() };
211
212 $next->isa( 'PPI::Token::Structure' )
213 and return $LEGAL_NEXT_STRUCT{ $next->content() };
214
215 return;
216 }
217}
218
219{
220
22123µs232µs Readonly::Hash my %LEGAL_PREV_OPER => hashify(
# spent 28µs making 1 call to Readonly::Hash # spent 4µs making 1 call to Perl::Critic::Utils::hashify
222 qw{ && || ! == != > >= < <= and or not } );
223
22412µs222µs Readonly::Hash my %LEGAL_PREV_WORD => hashify(
# spent 20µs making 1 call to Readonly::Hash # spent 2µs making 1 call to Perl::Critic::Utils::hashify
225 qw{ if unless } );
226
227 sub _legal_before_size_check {
228 my ( $prev ) = @_;
229
230 $prev
231 or return $TRUE;
232
233 $prev->isa( 'PPI::Token::Operator' )
234 and return $LEGAL_PREV_OPER{ $prev->content() };
235
236 $prev->isa( 'PPI::Token::Word' )
237 and return $LEGAL_PREV_WORD{ $prev->content() };
238
239 return;
240 }
241
242}
243
244sub _is_postfix_foreach {
245 my ($magic) = @_;
246
247 my $sibling = $magic;
248 while ( $sibling = $sibling->snext_sibling ) {
249 return $TRUE
250 if
251 $sibling->isa('PPI::Token::Word')
252 and $sibling =~ m< \A for (?:each)? \z >xms;
253 }
254 return;
255}
256
257sub _is_cast_of_array {
258 my ($magic) = @_;
259
260 my $prev = $magic->sprevious_sibling;
261
262 return $TRUE
263 if ( $prev && $prev->content() eq $AT )
264 and $prev->isa('PPI::Token::Cast');
265 return;
266}
267
268# This subroutine recognizes (e.g.) $$_[0]. This is a use of $_ (equivalent to
269# $_->[0]), not @_.
270
271sub _is_cast_of_scalar {
272 my ($magic) = @_;
273
274 my $prev = $magic->sprevious_sibling;
275 my $next = $magic->snext_sibling;
276
277 return $DOLLAR_ARG eq $magic->content() &&
278 $prev && $prev->isa('PPI::Token::Cast') &&
279 $DOLLAR eq $prev->content() &&
280 $next && $next->isa('PPI::Structure::Subscript');
281}
282
283# A literal @_ is allowed as the argument for a delegation.
284# An example of the idiom we are looking for is $self->SUPER::foo(@_).
285# The argument list of (@_) is required; no other use of @_ is allowed.
286
287sub _is_delegation {
288 my ($self, $magic) = @_;
289
290 $AT_ARG eq $magic->content() or return; # Not a literal '@_'.
291 my $parent = $magic->parent() # Don't know what to do with
292 or return; # orphans.
293 $parent->isa( 'PPI::Statement::Expression' )
294 or return; # Parent must be expression.
295 1 == $parent->schildren() # '@_' must stand alone in
296 or return; # its expression.
297 $parent = $parent->parent() # Still don't know what to do
298 or return; # with orphans.
299 $parent->isa ( 'PPI::Structure::List' )
300 or return; # Parent must be a list.
301 1 == $parent->schildren() # '@_' must stand alone in
302 or return; # the argument list.
303 my $subroutine_name = $parent->sprevious_sibling()
304 or return; # Missing sub name.
305 $subroutine_name->isa( 'PPI::Token::Word' )
306 or return;
307 $self->{_allow_delegation_to}{$subroutine_name}
308 and return 1;
309 my ($subroutine_namespace) = $subroutine_name =~ m/ \A ( .* ::) \w+ \z /smx
310 or return;
311 return $self->{_allow_delegation_to}{$subroutine_namespace};
312}
313
314
315sub _get_arg_symbols {
316 my ($statement) = @_;
317
318 return grep {$AT_ARG eq $_->symbol} @{$statement->find(\&_magic_finder) || []};
319}
320
321sub _magic_finder {
322 # Find all @_ and $_[\d+] not inside of nested subs
323 my (undef, $elem) = @_;
324 return $TRUE if $elem->isa('PPI::Token::Magic'); # match
325
326 if ($elem->isa('PPI::Structure::Block')) {
327 # don't descend into a nested named sub
328 return if $elem->statement->isa('PPI::Statement::Sub');
329
330 my $prev = $elem->sprevious_sibling;
331 # don't descend into a nested anon sub block
332 return if $prev
333 and $prev->isa('PPI::Token::Word')
334 and 'sub' eq $prev->content();
335 }
336
337 return $FALSE; # no match, descend
338}
339
340
34119µs1;
342
343__END__
Report produced by the NYTProf 6.01 Perl profiler, developed by Tim Bunce and Adam Kaplan.