File Coverage

blib/lib/Perl/Critic/Policy/Variables/ProhibitUnusedVarsStricter.pm
Criterion Covered Total %
statement 387 415 93.2
branch 226 300 75.3
condition 48 67 71.6
subroutine 46 48 95.8
pod 4 5 80.0
total 711 835 85.1


line stmt bran cond sub pod time code
1             package Perl::Critic::Policy::Variables::ProhibitUnusedVarsStricter;
2              
3 2     2   648513 use 5.006001;
  2         8  
4 2     2   11 use strict;
  2         5  
  2         60  
5 2     2   8 use warnings;
  2         4  
  2         132  
6              
7 2     2   11 use English qw{ -no_match_vars };
  2         4  
  2         16  
8              
9 2     2   1507 use PPI::Document 1.281;
  2         146201  
  2         96  
10 2     2   1373 use PPIx::QuoteLike 0.011;
  2         387668  
  2         158  
11 2         193 use PPIx::QuoteLike::Constant 0.011 qw{
12             LOCATION_LINE
13             LOCATION_LOGICAL_FILE
14             LOCATION_LOGICAL_LINE
15             LOCATION_CHARACTER
16             LOCATION_COLUMN
17 2     2   23 };
  2         43  
18 2     2   17 use PPIx::Regexp 0.071;
  2         57  
  2         77  
19 2     2   14 use Readonly;
  2         5  
  2         138  
20 2     2   15 use Scalar::Util qw{ refaddr };
  2         4  
  2         117  
21              
22 2     2   15 use Perl::Critic::Exception::Fatal::PolicyDefinition;
  2         6  
  2         121  
23 2     2   16 use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
  2         4  
  2         165  
24 2     2   16 use Perl::Critic::Utils qw< :booleans :characters hashify :severities >;
  2         5  
  2         208  
25              
26 2     2   983 use base 'Perl::Critic::Policy';
  2         30  
  2         1779  
27              
28             our $VERSION = '0.115';
29              
30             Readonly::Scalar my $DEREF => q/->/;
31              
32             #-----------------------------------------------------------------------------
33              
34             Readonly::Scalar my $EXPL =>
35             q<Unused variables clutter code and make it harder to read>;
36              
37             # Determine whether a PPI::Statement::Variable refers to a global or a
38             # lexical variable. We need to track globals to avoid false negatives
39             # from things like
40             #
41             # my $foo;
42             # {
43             # our $foo;
44             # $foo = 'bar';
45             # }
46             #
47             # but we do not need to track 'local', because if you
48             # s/ \b our \b /local/smxg
49             # in the above, Perl complains that you can not localize a lexical
50             # variable, rather than localizing the corresponding global variable.
51             Readonly::Hash my %GLOBAL_DECLARATION => (
52             my => $FALSE,
53             state => $FALSE,
54             our => $TRUE,
55             );
56              
57             Readonly::Scalar my $CATCH => 'catch';
58              
59             Readonly::Scalar my $PACKAGE => '_' . __PACKAGE__;
60              
61             Readonly::Scalar my $LEFT_BRACE => q<{>; # } Seems P::C::U should have
62              
63             Readonly::Hash my %IS_COMMA => hashify( $COMMA, $FATCOMMA );
64             Readonly::Hash my %IS_INC_DEC => hashify( qw{ ++ -- } );
65             Readonly::Hash my %LOW_PRECEDENCE_BOOLEAN => hashify( qw{ and or xor } );
66              
67             Readonly::Array my @DOUBLE_QUOTISH => qw{
68             PPI::Token::Quote::Double
69             PPI::Token::Quote::Interpolate
70             PPI::Token::QuoteLike::Backtick
71             PPI::Token::QuoteLike::Command
72             PPI::Token::QuoteLike::Readline
73             PPI::Token::HereDoc
74             };
75             Readonly::Array my @REGEXP_ISH => qw{
76             PPI::Token::Regexp::Match
77             PPI::Token::Regexp::Substitute
78             PPI::Token::QuoteLike::Regexp
79             };
80              
81             #-----------------------------------------------------------------------------
82              
83             sub supported_parameters { return (
84             {
85 61     61 0 4561918 name => 'allow_if_computed_by',
86             description => 'Allow if computed by one of these',
87             behavior => 'string list',
88             },
89             { name => 'prohibit_reference_only_variables',
90             description => 'Prohibit reference-only variables',
91             behavior => 'boolean',
92             default_string => '0',
93             },
94             { name => 'prohibit_returned_lexicals',
95             description => 'Prohibit returned lexicals',
96             behavior => 'boolean',
97             default_string => '0',
98             },
99             { name => 'allow_unused_subroutine_arguments',
100             description => 'Allow unused subroutine arguments',
101             behavior => 'boolean',
102             default_string => '0',
103             },
104             {
105             name => 'allow_state_in_expression',
106             description => 'Allow state variable with low-precedence Boolean',
107             behavior => 'boolean',
108             default_string => '0',
109             },
110             {
111             name => 'check_catch',
112             description => 'Check the catch() clause of try/catch',
113             behavior => 'boolean',
114             default_string => '0',
115             },
116             {
117             name => 'dump',
118             description => 'UNSUPPORTED: Dump symbol definitions',
119             behavior => 'boolean',
120             default_string => '0',
121             },
122             {
123             name => 'trace',
124             description => 'UNSUPPORTED: Trace variable processing',
125             behavior => 'string list',
126             },
127             ) }
128              
129 45     45 1 3696 sub default_severity { return $SEVERITY_MEDIUM }
130 0     0 1 0 sub default_themes { return qw< trw maintenance > }
131 60     60 1 1089244 sub applies_to { return qw< PPI::Document > }
132              
133             #-----------------------------------------------------------------------------
134              
135             sub violates {
136             # my ( $self, $elem, $document ) = @_;
137 60     60 1 947 my ( $self, undef, $document ) = @_;
138              
139 60         695 $self->{$PACKAGE} = {
140             declared => {}, # Keyed by PPI::Token::Symbol->symbol().
141             # Values are a list of hashes
142             # representing declarations of the given
143             # symbol, in reverse order. In each
144             # hash:
145             # {declaration} is the PPI statement
146             # object in which the variable is
147             # declared;
148             # {element} is the PPI::Token::Symbol
149             # {is_allowed_computation} is true
150             # if the value of the symbol is
151             # initialized using one of the
152             # allowed subroutines or classes
153             # (e.g. Scope::Guard).
154             # {is_global} is true if the declaration
155             # is a global (i.e. is 'our', not 'my');
156             # {is_state_in_expression} is true if
157             # the variable is a 'state' variable
158             # and the assignment is part of an
159             # expression.
160             # {is_unpacking} is true if the
161             # declaration occurs in an argument
162             # unpacking;
163             # {taking_reference} is true if the code
164             # takes a reference to the declared
165             # variable;
166             # {used} is a count of the number of
167             # times that declaration was used,
168             # initialized to 0.
169              
170             is_declaration => {}, # Keyed by refaddr of PPI::Token::Symbol.
171             # True if the object represents a
172             # declaration.
173              
174             need_sort => $FALSE, # Boolean that says whether the symbol
175             # declarations need to be sorted in
176             # lexical order. Recording a declaration
177             # must set this. Recording a use must
178             # clear this, doing the sort if it was
179             # previously set.
180              
181             ppix_objects => {}, # Cache of PPIx::QuoteLike and
182             # PPIx::Regexp objects indexed by
183             # refaddr of parent element.
184              
185             parent_element => {}, # PPI::Element objects from which
186             # PPI::Document objects have been
187             # derived, indexed by refaddr of derived
188             # document.
189             };
190              
191             # Ensure entire document is indexed. We don't call index_locations()
192             # because that is unconditional. We wrap the whole thing in an eval
193             # because last_token() can fail under undiagnosed circumstances.
194             {
195 60         225 local $EVAL_ERROR = undef;
  60         180  
196 60         209 eval { ## no critic (RequireCheckingReturnValueOfEval)
197 60 50       537 if ( my $token = $document->last_token() ) {
198 60         2779 $token->location();
199             }
200             }
201             }
202              
203 60         1417 $self->_get_symbol_declarations( $document );
204              
205 60         319 $self->_get_symbol_uses( $document );
206              
207             $self->{_dump}
208 60 50       261 and $self->_dump();
209              
210 60         258 return $self->_get_violations();
211              
212             }
213              
214             #-----------------------------------------------------------------------------
215              
216             sub _dump {
217 0     0   0 my ( $self ) = @_;
218 0         0 foreach my $name ( sort keys %{ $self->{$PACKAGE}{declared} } ) {
  0         0  
219             # NOTE that 'print { STDERR } ... ' does not compile under
220             # strict refs. '{ *STDERR }' is a terser way to satisfy
221             # InputOutput::RequireBracedFileHandleWithPrint.
222 0         0 print { *STDERR } "$name\n";
  0         0  
223 0         0 foreach my $decl ( @{ $self->{$PACKAGE}{declared}{$name} } ) {
  0         0  
224 0         0 my $sym = $decl->{element};
225 0         0 my $fn = $sym->logical_filename();
226 0 0       0 if ( defined $fn ) {
227 0         0 $fn =~ s/ (?= [\\'] ) /\\/smxg;
228 0         0 $fn = "'$fn'";
229             } else {
230 0         0 $fn = 'undef';
231             }
232 0         0 printf { *STDERR }
233             " %s line %d column %d: used %d; returned %d\n",
234             $fn,
235             $sym->logical_line_number(),
236             $sym->column_number(),
237             $decl->{used},
238 0   0     0 $decl->{returned_lexical} || 0,
239             }
240             }
241 0         0 return;
242             }
243              
244             #-----------------------------------------------------------------------------
245              
246             sub _get_symbol_declarations {
247 60     60   182 my ( $self, $document ) = @_;
248              
249 60         416 $self->_get_variable_declarations( $document );
250              
251 60         455 $self->_get_stray_variable_declarations( $document );
252              
253             $self->{_check_catch}
254 60 100       241 and $self->_get_catch_declarations( $document );
255              
256 60         382 $self->_get_signature_declarations( $document );
257              
258 60         178 return;
259              
260             }
261              
262             #-----------------------------------------------------------------------------
263              
264             # We assume the argument is actually eligible for this operation.
265             sub _get_ppix_quotelike {
266 62     62   195 my ( $self, $elem ) = @_;
267 62   66     718 return $self->{$PACKAGE}{ppix_objects}{ refaddr $elem } ||=
268             PPIx::QuoteLike->new( $elem );
269             }
270              
271             #-----------------------------------------------------------------------------
272              
273             # We assume the argument is actually eligible for this operation. The
274             # complication here is that if we are dealing with an element of a
275             # Perl::Critic::Document we want to call ppix_regexp_from_element(),
276             # since that caches the returned object, making it available to all
277             # policies. But the ppi() method returns a PPI::Document, so the best we
278             # can do is to cache locally.
279             sub _get_ppix_regexp {
280 18     18   73 my ( $self, $elem ) = @_;
281 18   66     161 return $self->{$PACKAGE}{ppix_objects}{ refaddr $elem } ||= do {
282 9         71 my $doc = $elem->top();
283 9         177 my $code;
284 9 50       143 ( $code = $doc->can( 'ppix_regexp_from_element' ) ) ?
285             $code->( $doc, $elem ) :
286             PPIx::Regexp->new( $elem );
287             };
288             }
289              
290             #-----------------------------------------------------------------------------
291              
292             # Get the PPI::Document that represents a PPIx::* class that supports
293             # one. The arguments are:
294             # $ppix_elem - the PPIx::* element providing the document. This MUST
295             # support the ->ppi() method.
296             # $elem - the original PPI::Element from which this element was
297             # derived.
298             # NOTE that all calls to ->ppi() MUST come through here.
299             sub _get_derived_ppi_document {
300 74     74   256 my ( $self, $ppix_elem, $elem ) = @_;
301 74 50       386 my $ppi = $ppix_elem->ppi()
302             or return;
303 74   66     68128 $self->{$PACKAGE}{parent_element}{ refaddr( $ppi ) } ||= $elem;
304 74         358 return $ppi;
305             }
306              
307             #-----------------------------------------------------------------------------
308              
309             # Get the PPI::Element that is the parent of the given PPI::Element,
310             # taking into account that the given element may be a derived
311             # PPI::Document.
312             # NOTE that all calls to PPI::Element->parent() MUST come through here.
313             sub _get_parent_element {
314 255     255   655 my ( $self, $elem ) = @_;
315 255 100       922 if ( my $parent = $elem->parent() ) {
316 213         2439 return $parent;
317             } else {
318 42         474 return $self->{$PACKAGE}{parent_element}{ refaddr( $elem ) };
319             }
320             }
321              
322             #-----------------------------------------------------------------------------
323              
324             # Get the lowest parent of the inner element that is in the same
325             # document as the outer element.
326             sub _get_lowest_in_same_doc {
327 86     86   245 my ( $self, $inner_elem, $outer_elem ) = @_;
328 86 50       388 my $outer_top = $outer_elem->top()
329             or return;
330 86         1402 while ( 1 ) {
331 120 50       368 my $inner_top = $inner_elem->top()
332             or last;
333 120 100       2297 $inner_top == $outer_top
334             and return $inner_elem;
335 38 100       287 $inner_elem = $self->_get_parent_element( $inner_top )
336             or last;
337             }
338 4         27 return;
339             }
340              
341             #-----------------------------------------------------------------------------
342              
343             sub _get_ppi_statement_variable {
344 97     97   335 my ( $self, $document ) = @_;
345              
346 97 100       266 my @rslt = @{ $document->find( 'PPI::Statement::Variable' ) || [] };
  97         500  
347              
348 97         17106 foreach my $class ( @DOUBLE_QUOTISH ) {
349 582 100       79743 foreach my $elem ( @{ $document->find( $class ) || [] } ) {
  582         1850  
350 31 50       1588 my $str = $self->_get_ppix_quotelike( $elem )
351             or next;
352 31 100       67687 foreach my $code ( @{ $str->find(
  31         208  
353             'PPIx::QuoteLike::Token::Interpolation' ) || [] } ) {
354 28 50       2888 my $ppi = $self->_get_derived_ppi_document( $code, $elem )
355             or next;
356 28         182 push @rslt, $self->_get_ppi_statement_variable( $ppi );
357             }
358             }
359             }
360              
361 97         15668 foreach my $class ( @REGEXP_ISH ) {
362 291 100       30031 foreach my $elem ( @{ $document->find( $class ) || [] } ) {
  291         943  
363 9 50       1118 my $pre = $self->_get_ppix_regexp( $elem )
364             or next;
365 9 50       122393 foreach my $code ( @{ $pre->find(
  9         47  
366             'PPIx::Regexp::Token::Code' ) || [] } ) {
367 9 50       3930 my $ppi = $self->_get_derived_ppi_document( $code, $elem )
368             or next;
369 9         55 push @rslt, $self->_get_ppi_statement_variable( $ppi );
370             }
371             }
372             }
373              
374 97         17487 return @rslt;
375             }
376              
377             #-----------------------------------------------------------------------------
378              
379             # The catch() clause of try/catch is a special case because the 'my' is
380             # implied. Also the syntax requires you to specify a variable even if
381             # you have no intention of using it.
382             # NOTE that we assume that if we get called, the check is to be done.
383             sub _get_catch_declarations {
384 2     2   6 my ( $self, $document ) = @_;
385 2 50       7 foreach my $word ( @{ $document->find( 'PPI::Token::Word' ) || [] } ) {
  2         56  
386 7 100       74 $CATCH eq $word->content()
387             or next;
388 2 50       19 my $list = $word->snext_sibling()
389             or next;
390 2 50       94 $list->isa( 'PPI::Structure::List' )
391             or next;
392 2 50       25 my $block = $list->snext_sibling()
393             or next;
394 2 50       72 $block->isa( 'PPI::Structure::Block' )
395             or next;
396 2 50       7 foreach my $sym ( @{ $list->find( 'PPI::Token::Symbol' ) || [] } ) {
  2         9  
397             # Should be only one, but ...
398 2         728 $self->_record_symbol_definition(
399             $sym, $sym->statement() );
400             }
401             }
402 2         11 return;
403             }
404              
405             #-----------------------------------------------------------------------------
406              
407             # Signatures are a special case not only because the 'my' is implied but
408             # because unused variable placeholders are specified by a lone sigil,
409             # which parses as a PPI::Token::Symbol, at least most of the time. NOTE
410             # that you need at least PPI 1.290 to actually get a PPI::Structure::Signature.
411             sub _get_signature_declarations {
412 60     60   188 my ( $self, $document ) = @_;
413              
414 60 100       173 foreach my $sig ( @{ $document->find( 'PPI::Structure::Signature' )
  60         255  
415             || [] } ) {
416              
417 3         57 foreach my $expr ( $sig->schildren() ) {
418             # The signature contains a PPI::Statement::Expression.
419             # Within the expression, the first symbol we encounter is a
420             # declaration. Subsequent symbols will be uses until the
421             # next comma. We don't need to record the uses, because they
422             # will be found when we scan the document for them.
423 3         52 my $declaration = 1;
424 3         13 foreach my $elem ( $expr->schildren() ) {
425 5 100       80 if ( $elem->isa( 'PPI::Token::Symbol' ) ) {
    50          
426 4 100       20 if ( $declaration ) {
427 3         9 $declaration = 0; # No more until next comma
428 3 50       15 length( $elem->content() ) > 1
429             and $self->_record_symbol_definition(
430             $elem, $elem->statement() );
431             }
432             } elsif ( $elem->isa( 'PPI::Token::Operator' ) ) {
433 1 50       6 $IS_COMMA{ $elem->content() }
434             and $declaration = 1;
435             }
436             }
437             }
438             }
439 60         834 return;
440             }
441              
442             #-----------------------------------------------------------------------------
443              
444             # Sorry, but this is just basicly hard.
445             sub _get_variable_declarations {
446 60     60   238 my ( $self, $document ) = @_;
447              
448 60         292 foreach my $declaration ( $self->_get_ppi_statement_variable( $document ) ) {
449              
450             # This _should_ be the initial 'my', 'our' 'state'
451 102 50       1980 my $elem = $declaration->schild( 0 )
452             or next;
453              
454 102         2335 my $is_unpacking = $declaration->content() =~ m<
455             = \s* (?: \@_ |
456             shift (?: \s* \@_ )? ) |
457             \$_ [[] .*? []]
458             \s* ;? \z >smx;
459              
460 102         6632 my $taking_reference = $self->_taking_reference_of_variable(
461             $declaration );
462              
463 102         790 my $returned_lexical = $self->_returned_lexical( $declaration );
464              
465 102         1229 while ( 1 ) {
466              
467             # Looking for 'my', 'our', or 'state'
468 401 100       10304 $elem->isa( 'PPI::Token::Word' )
469             or next;
470             defined( my $is_global = $GLOBAL_DECLARATION{
471 126 100       443 $elem->content()} )
472             or next;
473              
474 104 100       2065 $elem = $elem->snext_sibling()
475             or last;
476              
477             # We can't just look for symbols, since PPI parses the
478             # parens in
479             # open( my $fh, '>&', \*STDOUT )
480             # as a PPI::Statement::Variable, and we get a false positive
481             # on STDOUT.
482 102         4806 my @symbol_list;
483 102 100       424 if ( $elem->isa( 'PPI::Token::Symbol' ) ) {
    50          
484 93         239 push @symbol_list, $elem;
485             } elsif ( $elem->isa( 'PPI::Structure::List' ) ) {
486             push @symbol_list, @{
487 9 50       149 $elem->find( 'PPI::Token::Symbol' ) || [] };
  9         38  
488             } else {
489 0         0 next;
490             }
491              
492 102         4343 my ( $assign, $is_allowed_computation,
493             $is_state_in_expression ) =
494             $self->_get_allowed_and_state( $elem, $declaration );
495              
496 102         302 foreach my $symbol ( @symbol_list ) {
497              
498 109 100       461 if ( $assign ) {
499 88 50 33     356 $symbol->logical_line_number() <
      33        
500             $assign->logical_line_number()
501             or $symbol->logical_line_number() ==
502             $assign->logical_line_number()
503             and $symbol->column_number() < $assign->column_number()
504             or next;
505             }
506              
507             $self->_record_symbol_definition(
508 109         9023 $symbol, $declaration,
509             is_allowed_computation => $is_allowed_computation,
510             is_global => $is_global,
511             is_state_in_expression => $is_state_in_expression,
512             is_unpacking => $is_unpacking,
513             taking_reference => $taking_reference,
514             returned_lexical => $returned_lexical,
515             );
516              
517             }
518              
519             } continue {
520 399 100 66     2716 $elem
521             and $elem = $elem->snext_sibling()
522             or last;
523             }
524              
525             }
526              
527 60         1541 return;
528             }
529              
530             # FIXME this is a God-awful mish-mash forced on me by the fact that PPI
531             # does not in fact parse all variable declarations as
532             # PPI::Statement::Variable objects, so this code needs to be shared
533             # among multiple code paths. The arguments are:
534             # $self
535             # $elem - the relevant element of the statement
536             # $declaration - the statement that declares the variable
537             # $type - 'my', 'our', 'state'. Forbidden (but not enforcded) if
538             # $declaration isa PPI::Statement::Variable, otherwise required.
539             sub _get_allowed_and_state {
540 109     109   343 my ( $self, $elem, $declaration, $type ) = @_;
541              
542 109         277 my ( $assign, $is_allowed_computation,
543             $is_state_in_expression );
544              
545 109         396 while ( $elem = $elem->snext_sibling() ) {
546 115 100       3745 $elem->isa( 'PPI::Token::Operator' )
547             or next;
548 97         340 my $content = $elem->content();
549 97 100       901 $IS_COMMA{$content}
550             and last;
551 93 100       1101 if ( $EQUAL eq $content ) {
    100          
552 86         223 $assign = $elem;
553              
554 86         332 $is_allowed_computation = $self->_is_allowed_computation(
555             $assign );
556              
557 86         412 $is_state_in_expression = $self->_is_state_in_expression(
558             $declaration, $assign, $type );
559              
560 86         262 last;
561             } elsif ( $IS_INC_DEC{$content} ) {
562 4         21 $is_state_in_expression = 1;
563 4         7 last;
564             }
565             }
566              
567 109         1000 return ( $assign, $is_allowed_computation, $is_state_in_expression );
568             }
569              
570             #-----------------------------------------------------------------------------
571              
572             {
573              
574             Readonly::Hash my %IS_FOR => hashify( qw{ for foreach } );
575             Readonly::Hash my %IS_RETURN => hashify( qw{ return } );
576              
577             # Get stray declarations that do not show up in
578             # PPI::Statement::Variable statements. These show up in
579             # PPI::Statement::Compound (specifically 'for' and 'foreach'), and
580             # in PPI::Statement::Break (specifically 'return'). In the case of
581             # 'return', we do not need to descend into paren, because if there
582             # are parens, PPI produces a PPI::Statement::Variable.
583              
584             sub _get_stray_variable_declarations {
585 60     60   227 my ( $self, $document ) = @_;
586              
587 60         693 foreach (
588             [ 'PPI::Statement::Compound' => {
589             want => \%IS_FOR,
590             returned_lexical => $FALSE,
591             } ],
592             [ 'PPI::Statement::Break' => {
593             want => \%IS_RETURN,
594             returned_lexical => $TRUE,
595             } ],
596             ) {
597 120         1076 my ( $class, $info ) = @{ $_ };
  120         376  
598 120         239 foreach my $declaration (
599 120 100       504 @{ $document->find( $class ) || [] }
600             ) {
601              
602 27 50       384 my $type = $declaration->schild( 0 )
603             or next;
604              
605 27         553 my $type_str = $type->content();
606              
607 27 100       1716 if ( $info->{want}{$type_str} ) {
608              
609 13 50       128 my $sib = $type->snext_sibling()
610             or next;
611              
612             # We're looking for 'my', 'state', or 'our'.
613 13 100       442 $sib->isa( 'PPI::Token::Word' )
614             or next;
615 8         25 my $sib_content = $sib->content();
616 8 50       61 defined( my $is_global = $GLOBAL_DECLARATION{$sib_content} )
617             or next;
618              
619 8 50       129 my $symbol = $sib->snext_sibling()
620             or next;
621 8 50       259 $symbol->isa( 'PPI::Token::Symbol' )
622             or next;
623              
624             $self->_record_symbol_definition(
625             $symbol, $declaration,
626             is_global => $is_global,
627             returned_lexical => $info->{returned_lexical},
628 8         32 );
629              
630             }
631              
632             }
633              
634             }
635              
636 60         956 return;
637             }
638              
639             }
640              
641             #-----------------------------------------------------------------------------
642              
643             sub _is_allowed_computation {
644 86     86   265 my ( $self, $elem ) = @_; # $elem presumed to be '='.
645              
646 86 50       295 my $next_sib = $elem->snext_sibling() or return;
647              
648 86 100       3201 if ( $next_sib->isa( 'PPI::Token::Word' ) ) {
    100          
649              
650             # We are presumed to be a subroutine call.
651 13         48 my $content = $next_sib->content();
652 13 100       103 $self->{_allow_if_computed_by}{$content}
653             and return $content;
654              
655             # We might be a static method call. This looks like
656             # bareword_1->bareword_2.
657 12 50       46 $next_sib = $next_sib->snext_sibling()
658             or return;
659 12 100 66     428 $next_sib->isa( 'PPI::Token::Operator' )
660             and $next_sib->content() eq $DEREF
661             or return;
662 2         21 $content .= $next_sib->content();
663              
664 2 50       13 $next_sib = $next_sib->snext_sibling()
665             or return;
666 2 50       64 $next_sib->isa( 'PPI::Token::Word' )
667             or return;
668 2         88 $content .= $next_sib->content();
669              
670 2 100       27 $self->{_allow_if_computed_by}{$content}
671             and return $content;
672              
673             } elsif ( $next_sib->isa( 'PPI::Token::Symbol' ) ) {
674              
675             # We might be a method call.
676 9 50       33 $next_sib = $next_sib->snext_sibling()
677             or return;
678 9 100 66     327 $next_sib->isa( 'PPI::Token::Operator' )
679             and q{->} eq $next_sib->content()
680             or return;
681 1 50       13 $next_sib = $next_sib->snext_sibling()
682             or return;
683 1         32 my $content = $next_sib->content();
684 1 50       10 $self->{_allow_if_computed_by}{$content}
685             and return $content;
686             }
687              
688 65         257 return;
689             }
690              
691             #-----------------------------------------------------------------------------
692              
693             # Find cases where the value of a state variable is used by the
694             # statement that declares it, or an expression in which that statement
695             # appears. The user may wish to accept such variables even if the
696             # variable itself appears only in the statement that declares it.
697             #
698             # $declaration is assumed to be a PPI::Statement::Variable. We return
699             # $FALSE unless it declares state variables.
700             #
701             # $operator is the first assignment operator in $declaration.
702             #
703             # NOTE that this will never be called for stuff like
704             # $foo and state $bar = 42
705             # because PPI does not parse this as a PPI::Statement::Variable.
706             sub _is_state_in_expression {
707 86     86   262 my ( $self, $declaration, $operator, $type ) = @_;
708              
709 86 100       283 unless ( defined $type ) { ## no critic (ProhibitUnlessBlocks)
710 84 50       409 $declaration->can( 'type' )
711             or throw_internal
712             'BUG - $type required if $declaration->type() does not exist'; ## no critic (RequireInterpolationOfMetachars)
713 84         401 $type = $declaration->type();
714             }
715              
716             # We're only interested in state declarations.
717 86 100       4908 q<state> eq $type
718             or return $FALSE;
719              
720             # We accept things like
721             # state $foo = bar() and ...
722 7         18 my $next_sib = $operator;
723 7         25 while ( $next_sib = $next_sib->snext_sibling() ) {
724             $next_sib->isa( 'PPI::Token::Operator' )
725 14 100 66     518 and $LOW_PRECEDENCE_BOOLEAN{ $next_sib->content() }
726             and return $TRUE;
727             }
728              
729             # We accept things like
730             # ... ( state $foo = bar() ) ...
731             # IF at least one of the ellipses has an operator adjacent to our
732             # declaration.
733 5         151 my $elem = $declaration;
734 5         67 while ( $elem ) {
735 14         43 foreach my $method ( qw{ snext_sibling sprevious_sibling } ) {
736 27 100       313 my $sib = $elem->$method()
737             or next;
738 9 100       297 $sib->isa( 'PPI::Token::Operator' )
739             and return $TRUE;
740             }
741 13         195 $elem = $self->_get_parent_element( $elem );
742             }
743              
744             # There are no other known cases where a state variable's value can
745             # be used without the variable name appearing anywhere other than
746             # its initialization.
747 4         17 return $FALSE;
748             }
749              
750             #-----------------------------------------------------------------------------
751              
752             sub _taking_reference_of_variable {
753 102     102   390 my ( $self, $elem ) = @_; # Expect a PPI::Statement::Variable
754 102 50       434 my $parent = $self->_get_parent_element( $elem )
755             or return;
756 102         230 my $cast;
757              
758 102 100       824 if ( $parent->isa( 'PPI::Structure::List' ) ) {
    100          
759              
760 12 100       125 $cast = $parent->sprevious_sibling()
761             or return;
762              
763             } elsif ( $parent->isa( 'PPI::Structure::Block' ) ) {
764              
765 25 100       134 my $prev = $parent->sprevious_sibling()
766             or return;
767              
768 14 100       534 $prev->isa( 'PPI::Token::Word' )
769             or return;
770 13 100       49 'do' eq $prev->content()
771             or return;
772              
773 4         35 $cast = $prev->sprevious_sibling()
774              
775             }
776              
777             $cast
778 80 100       744 or return;
779 13 100       83 $cast->isa( 'PPI::Token::Cast' )
780             or return;
781 6         20 return q<\\> eq $cast->content()
782             }
783              
784             #-----------------------------------------------------------------------------
785              
786             sub _returned_lexical {
787 102     102   320 my ( $self, $elem ) = @_; # Expect a PPI::Statement::Variable
788 102 50       279 my $parent = $self->_get_parent_element( $elem )
789             or return;
790 102 100       482 my $stmt = $parent->statement()
791             or return;
792 38 100       1088 $stmt->isa( 'PPI::Statement::Break' )
793             or return;
794 4 50       13 my $kind = $stmt->schild( 0 )
795             or return; # Should never happen.
796 4         75 return 'return' eq $kind->content();
797             }
798              
799             #-----------------------------------------------------------------------------
800              
801             {
802              
803             Readonly::Hash my %CAST_FOR_BARE_BRACKETED_VARIABLE => qw{
804             @ @
805             $ $
806             $$ $
807             % %
808             };
809              
810             sub _get_symbol_uses {
811 97     97   264 my ( $self, $document ) = @_;
812              
813 97         296 foreach my $symbol (
814 97 100       335 @{ $document->find( 'PPI::Token::Symbol' ) || [] }
815             ) {
816 215 100       15378 $self->{$PACKAGE}{is_declaration}->{ refaddr( $symbol ) } and next;
817              
818 93         428 $self->_record_symbol_use( $document, $symbol );
819              
820             }
821              
822             # For some reason, PPI parses '$#foo' as a
823             # PPI::Token::ArrayIndex. $#$foo is parsed as a Cast followed
824             # by a Symbol, so as long as nobody decides the '$#' cast causes
825             # $elem->symbol() to return something other than '$foo', we're
826             # cool.
827 97         1027 foreach my $elem (
828 97 100       405 @{ $document->find( 'PPI::Token::ArrayIndex' ) || [] }
829             ) {
830              
831 1         12 my $name = $elem->content();
832 1 50       8 $name =~ s/ \A \$ [#] /@/smx or next;
833              
834 1         4 $self->_record_symbol_use( $document, $elem, $name );
835             }
836              
837             # Occasionally you see something like ${foo} outside quotes.
838             # This is legitimate, though PPI parses it as a cast followed by
839             # a block. On the assumption that there are fewer blocks than
840             # words in most Perl, we start at the top and work down. Perl
841             # also handles punctuation variables specified this way, but
842             # since PPI goes berserk when it sees this, we won't bother.
843             #
844             # And EXTREMELY occasionally something like $${foo} gets parsed
845             # as magic followed by subscript.
846 97         15286 foreach my $class ( qw{
847             PPI::Structure::Block
848             PPI::Structure::Subscript
849             }
850             ) {
851 194         13995 foreach my $elem (
852 194 100       687 @{ $document->find( $class ) || [] }
853             ) {
854 64 100       5759 $LEFT_BRACE eq $elem->start() # Only needed for subscript.
855             or next;
856 56 100       1512 my $previous = $elem->sprevious_sibling()
857             or next;
858 44 100 66     1927 $previous->isa( 'PPI::Token::Cast' )
859             or $previous->isa( 'PPI::Token::Magic' ) # $${foo}
860             or next;
861             my $sigil = $CAST_FOR_BARE_BRACKETED_VARIABLE{
862 4 50       13 $previous->content() }
863             or next;
864              
865 4         78 my @kids = $elem->schildren();
866 4 50       56 1 == @kids
867             or next;
868 4 50       21 $kids[0]->isa( 'PPI::Statement' )
869             or next;
870              
871 4         15 my @grand_kids = $kids[0]->schildren();
872 4 50       39 1 == @grand_kids
873             or next;
874              
875             # Yes, "${v6}_..." occurred, and was parsed as a
876             # PPI::Token::Number::Version by PPI 1.270.
877 4 100 66     52 $grand_kids[0]->isa( 'PPI::Token::Word' )
878             or $grand_kids[0]->isa( 'PPI::Token::Number::Version' )
879             or next;
880              
881 1         4 $self->_record_symbol_use( $document, $elem,
882             $sigil . $grand_kids[0]->content(),
883             );
884             }
885             }
886              
887 97         10313 $self->_get_regexp_symbol_uses( $document );
888              
889 97         550 $self->_get_double_quotish_string_uses( $document );
890              
891 97         388 return;
892             }
893              
894             }
895              
896             #-----------------------------------------------------------------------------
897              
898             # Record the definition of a symbol.
899             # $symbol is the PPI::Token::Symbol
900             # $declaration is the statement that declares it
901             # %arg is optional arguments, collected and recorded to support the
902             # various configuration items.
903             sub _record_symbol_definition {
904 129     129   1430 my ( $self, $symbol, $declaration, %arg ) = @_;
905              
906 129         383 my $ref_addr = refaddr( $symbol );
907 129         604 my $sym_name = $symbol->symbol();
908              
909 129         8808 $self->{$PACKAGE}{is_declaration}{$ref_addr} = 1;
910              
911 129         411 $arg{declaration} = $declaration;
912 129         391 $arg{element} = $symbol;
913 129         324 $arg{used} = 0;
914              
915 129         364 foreach my $key ( qw{
916             is_allowed_computation
917             is_global
918             is_state_in_expression
919             is_unpacking
920             taking_reference
921             returned_lexical
922             } ) {
923             exists $arg{$key}
924 774 100       2354 or $arg{$key} = $FALSE;
925             }
926              
927 129 50       491 if ( $self->{_trace}{$sym_name} ) {
928 0         0 printf { *STDERR }
  0         0  
929             "%s 0x%x declared at line %d col %d\n",
930             $sym_name, $ref_addr,
931             $symbol->logical_line_number(), $symbol->column_number();
932             }
933              
934 129   100     287 push @{ $self->{$PACKAGE}{declared}{ $sym_name } ||= [] }, \%arg;
  129         1111  
935              
936 129         413 $self->{$PACKAGE}{need_sort} = $TRUE;
937              
938 129         613 return;
939             }
940              
941             #-----------------------------------------------------------------------------
942              
943             sub _record_symbol_use {
944 95     95   339 my ( $self, undef, $symbol, $symbol_name ) = @_; # $document not used
945              
946 95         180 my $declaration;
947              
948 95 100       491 defined $symbol_name
949             or $symbol_name = $symbol->symbol();
950              
951 95 100       7584 if ( ! ( $declaration = $self->{$PACKAGE}{declared}{$symbol_name} ) ) {
952             # If we did not find a declaration for the symbol, it may
953             # have been declared en passant, as part of doing something
954             # else.
955 24 100       93 my $prev = $symbol->sprevious_sibling()
956             or return;
957 18 100       598 $prev->isa( 'PPI::Token::Word' )
958             or return;
959 10         35 my $type = $prev->content();
960 10 100       87 exists $GLOBAL_DECLARATION{$type}
961             or return;
962              
963             # Yup. It's a declaration. Record it.
964 7         69 $declaration = $symbol->statement();
965              
966 7         105 my $cast = $prev->sprevious_sibling();
967 7 50       201 if ( ! $cast ) {
968 0         0 my $parent;
969 0 0       0 $parent = $self->_get_parent_element( $prev )
970             and $cast = $parent->sprevious_sibling();
971             }
972              
973 7         36 my ( undef, $is_allowed_computation,
974             $is_state_in_expression ) =
975             $self->_get_allowed_and_state( $symbol, $declaration,
976             $type );
977              
978             $self->_record_symbol_definition(
979             $symbol, $declaration,
980             is_allowed_computation => $is_allowed_computation,
981 7         35 is_global => $GLOBAL_DECLARATION{$type},
982             is_state_in_expression => $is_state_in_expression,
983             taking_reference => _element_takes_reference( $cast ),
984             );
985              
986 7         25 return;
987             }
988              
989 71 100       295 if ( delete $self->{$PACKAGE}{need_sort} ) {
990             # Because we need multiple passes to find all the declarations,
991             # we have to put them in reverse order when we're done. We need
992             # to repeat the check because of the possibility of picking up
993             # declarations made in passing while trying to find uses.
994             # Re the 'no critic' annotation: I understand that 'reverse ...'
995             # is faster and clearer than 'sort { $b cmp $a } ...', but I
996             # think the dereferenes negate this.
997 33         90 foreach my $decls ( values %{ $self->{$PACKAGE}{declared} } ) {
  33         171  
998 59         263 @{ $decls } = map { $_->[0] }
  73         757  
999             sort { ## no critic (ProhibitReverseSortBlock)
1000 14 50       340 $b->[1][LOCATION_LOGICAL_LINE] <=>
1001             $a->[1][LOCATION_LOGICAL_LINE] ||
1002             $b->[1][LOCATION_CHARACTER] <=>
1003             $a->[1][LOCATION_CHARACTER]
1004             }
1005 73         452 map { [ $_, $_->{element}->location() ] }
1006 59         145 @{ $decls };
  59         155  
1007             }
1008             }
1009              
1010 71         174 foreach my $decl_scope ( @{ $declaration } ) {
  71         257  
1011             $self->_derived_element_is_in_lexical_scope_after_statement_containing(
1012             $symbol, $decl_scope->{declaration} )
1013 86 100       486 or next;
1014 70         1531 $decl_scope->{used}++;
1015 70 50       247 if ( $self->{_trace}{$symbol_name} ) {
1016 0         0 my $elem = $decl_scope->{element};
1017 0         0 printf { *STDERR }
  0         0  
1018             "%s at line %d col %d refers to 0x%x at line %d col %d\n",
1019             $symbol_name,
1020             $symbol->logical_line_number(),
1021             $symbol->column_number(),
1022             refaddr( $elem ),
1023             $elem->logical_line_number(),
1024             $elem->column_number(),
1025             ;
1026             }
1027 70         252 return;
1028             }
1029              
1030 1 50       32 if ( $self->{_trace}{$symbol_name} ) {
1031 0         0 printf { *STDERR }
  0         0  
1032             "Failed to resolve %s at line %d col %d\n",
1033             $symbol_name,
1034             $symbol->logical_line_number(),
1035             $symbol->column_number(),
1036             ;
1037             }
1038              
1039 1         5 return;
1040              
1041             }
1042              
1043             sub _derived_element_is_in_lexical_scope_after_statement_containing {
1044 86     86   255 my ( $self, $inner_elem, $outer_elem ) = @_;
1045              
1046 86 100       333 my $effective_inner = $self->_get_lowest_in_same_doc( $inner_elem,
1047             $outer_elem )
1048             or return $FALSE;
1049              
1050 82         902 return _element_is_in_lexical_scope_after_statement_containing(
1051             $effective_inner, $outer_elem );
1052              
1053             }
1054              
1055             #-----------------------------------------------------------------------------
1056              
1057             sub _element_takes_reference {
1058 7     7   19 my ( $elem ) = @_;
1059 7   33     76 return $elem && $elem->isa( 'PPI::Token::Cast' ) &&
1060             $BSLASH eq $elem->content();
1061             }
1062              
1063             #-----------------------------------------------------------------------------
1064              
1065             sub _get_double_quotish_string_uses {
1066 97     97   308 my ( $self, $document ) = @_;
1067              
1068 97         354 foreach my $class ( @DOUBLE_QUOTISH ) {
1069 582         76544 foreach my $double_quotish (
1070 582 100       1802 @{ $document->find( $class ) || [] }
1071             ) {
1072              
1073 31 50       1153 my $str = $self->_get_ppix_quotelike( $double_quotish )
1074             or next;
1075              
1076 31         81 foreach my $interp ( @{
1077 31 100       209 $str->find( 'PPIx::QuoteLike::Token::Interpolation' ) || [] } ) {
1078              
1079 28 50       1718 my $subdoc = $self->_get_derived_ppi_document(
1080             $interp, $double_quotish )
1081             or next;
1082              
1083 28         140 $self->_get_symbol_uses( $subdoc, $double_quotish );
1084              
1085             }
1086              
1087             }
1088             }
1089              
1090 97         29205 return;
1091             }
1092              
1093             #-----------------------------------------------------------------------------
1094              
1095             sub _get_regexp_symbol_uses {
1096 97     97   352 my ( $self, $document ) = @_;
1097              
1098 97         551 foreach my $class ( @REGEXP_ISH ) {
1099              
1100 291 100       30760 foreach my $regex ( @{ $document->find( $class ) || [] } ) {
  291         890  
1101              
1102 9 50       1307 my $pre = $self->_get_ppix_regexp( $regex )
1103             or next;
1104              
1105 9         23 foreach my $code ( @{
1106 9 50       49 $pre->find( 'PPIx::Regexp::Token::Code' ) || [] } ) {
1107              
1108 9         3862 my $subdoc = $self->_get_derived_ppi_document( $code,
1109             $regex );
1110              
1111 9         37 $self->_get_symbol_uses( $subdoc, $regex );
1112             }
1113              
1114             }
1115              
1116             }
1117              
1118 97         15590 return;
1119             }
1120              
1121             #-----------------------------------------------------------------------------
1122              
1123             sub _get_violations {
1124 60     60   274 my ( $self ) = @_;
1125              
1126 60         124 my @in_violation;
1127              
1128 60         127 foreach my $name ( values %{ $self->{$PACKAGE}{declared} } ) {
  60         331  
1129 106         235 foreach my $declaration ( @{ $name } ) {
  106         258  
1130             $declaration->{is_global}
1131 129 100       399 and next;
1132             $declaration->{used}
1133 128 100       414 and next;
1134             $declaration->{is_allowed_computation}
1135 66 100       187 and next;
1136             $declaration->{is_state_in_expression}
1137             and $self->{_allow_state_in_expression}
1138 63 100 100     197 and next;
1139             $declaration->{taking_reference}
1140             and not $self->{_prohibit_reference_only_variables}
1141 59 100 100     215 and next;
1142             $declaration->{returned_lexical}
1143             and not $self->{_prohibit_returned_lexicals}
1144 55 100 100     186 and next;
1145             $declaration->{is_unpacking}
1146             and $self->{_allow_unused_subroutine_arguments}
1147 51 100 100     166 and next;
1148 45         164 push @in_violation, $declaration->{element};
1149             }
1150             }
1151              
1152 45         5698 return ( map { $self->violation(
1153             sprintf( '%s is declared but not used', $_->symbol() ),
1154             $EXPL,
1155             $_
1156 60 50       398 ) } sort { $a->logical_line_number() <=> $b->logical_line_number() ||
  28         589  
1157             $a->column_number() <=> $b->column_number() }
1158             @in_violation );
1159             }
1160              
1161             #-----------------------------------------------------------------------------
1162              
1163             # THIS CODE HAS ABSOLUTELY NO BUSINESS BEING HERE. It should probably be
1164             # its own module; PPIx::Scope or something like that. The problem is
1165             # that I no longer "own" it, and am having trouble getting modifications
1166             # through. So I have stuck it here for the moment, but I hope it will
1167             # not stay here. Other than here, it appears in Perl::Critic::Document
1168             # (the copy I am trying to get modified) and Perl::ToPerl6::Document (a
1169             # cut-and-paste of an early version.)
1170             #
1171             # THIS CODE IS PRIVATE TO THIS MODULE. The author reserves the right to
1172             # change it or remove it without any notice whatsoever. YOU HAVE BEEN
1173             # WARNED.
1174             #
1175             # This got hung on the Perl::Critic::Document, rather than living in
1176             # Perl::Critic::Utils::PPI, because of the possibility that caching of scope
1177             # objects would turn out to be desirable.
1178              
1179             # sub element_is_in_lexical_scope_after_statement_containing {...}
1180             sub _element_is_in_lexical_scope_after_statement_containing {
1181 82     82   232 my ( $inner_elem, $outer_elem ) = @_;
1182              
1183 82 50       272 $inner_elem->top() == $outer_elem->top()
1184             or Perl::Critic::Exception::Fatal::PolicyDefinition->throw(
1185             message => 'Elements must be in same document' );
1186              
1187             # If the outer element defines a scope, we're true if and only if
1188             # the outer element contains the inner element, and the inner
1189             # element is not somewhere that is hidden from the scope.
1190 82 100       2530 if ( $outer_elem->scope() ) {
1191 6         27 return _inner_element_is_in_outer_scope_really(
1192             $inner_elem, $outer_elem );
1193             }
1194              
1195             # In the more general case:
1196              
1197             # The last element of the statement containing the outer element
1198             # must be before the inner element. If not, we know we're false,
1199             # without walking the parse tree.
1200              
1201 76 50       271 my $stmt = $outer_elem->statement()
1202             or return;
1203              
1204 76         1199 my $last_elem = $stmt;
1205 76         385 while ( $last_elem->isa( 'PPI::Node' ) ) {
1206 78 50       319 $last_elem = $last_elem->last_element()
1207             or return;
1208             }
1209              
1210 76 50       1029 my $stmt_loc = $last_elem->location()
1211             or return;
1212              
1213 76 50       1307 my $inner_loc = $inner_elem->location()
1214             or return;
1215              
1216 76 50       1187 $stmt_loc->[LOCATION_LINE] > $inner_loc->[LOCATION_LINE]
1217             and return;
1218 76 100 100     314 $stmt_loc->[LOCATION_LINE] == $inner_loc->[LOCATION_LINE]
1219             and $stmt_loc->[LOCATION_CHARACTER] >= $inner_loc->[LOCATION_CHARACTER]
1220             and return;
1221              
1222             # Since we know the inner element is after the outer element, find
1223             # the element that defines the scope of the statement that contains
1224             # the outer element.
1225              
1226 71         165 my $parent = $stmt;
1227 71         309 while ( ! $parent->scope() ) {
1228             # Things appearing in the right-hand side of a
1229             # PPI::Statement::Variable are not in-scope to its left-hand
1230             # side. RESTRICTION -- this code does not handle truly
1231             # pathological stuff like
1232             # my ( $c, $d ) = qw{ e f };
1233             # my ( $a, $b ) = my ( $c, $d ) = ( $c, $d );
1234 80 50 66     351 _inner_is_defined_by_outer( $inner_elem, $parent )
1235             and _location_is_in_right_hand_side_of_assignment(
1236             $parent, $inner_elem )
1237             and return;
1238 80 50       1115 $parent = $parent->parent()
1239             or return;
1240             }
1241              
1242             # We're true if and only if the scope of the outer element contains
1243             # the inner element.
1244              
1245 71         847 return $inner_elem->descendant_of( $parent );
1246              
1247             }
1248              
1249             # Helper for element_is_in_lexical_scope_after_statement_containing().
1250             # Return true if and only if $outer_elem is a statement that defines
1251             # variables and $inner_elem is actually a variable defined in that
1252             # statement.
1253             sub _inner_is_defined_by_outer {
1254 80     80   224 my ( $inner_elem, $outer_elem ) = @_;
1255 80 100 100     698 $outer_elem->isa( 'PPI::Statement::Variable' )
1256             and $inner_elem->isa( 'PPI::Token::Symbol' )
1257             or return;
1258 37         167 my %defines = hashify( $outer_elem->variables() );
1259 37         3491 return $defines{$inner_elem->symbol()};
1260             }
1261              
1262             # Helper for element_is_in_lexical_scope_after_statement_containing().
1263             # Given that the outer element defines a scope, there are still things
1264             # that are lexically inside it but outside the scope. We return true if
1265             # and only if the inner element is inside the outer element, but not
1266             # inside one of the excluded elements. The cases handled so far:
1267             # for ----- the list is not part of the scope
1268             # foreach - the list is not part of the scope
1269              
1270             sub _inner_element_is_in_outer_scope_really {
1271 6     6   21 my ( $inner_elem, $outer_elem ) = @_;
1272 6 50       30 $outer_elem->scope()
1273             or return;
1274 6 50       32 $inner_elem->descendant_of( $outer_elem )
1275             or return;
1276 6 50       144 if ( $outer_elem->isa( 'PPI::Statement::Compound' ) ) {
1277 6 50       24 my $first = $outer_elem->schild( 0 )
1278             or return;
1279 6 50       130 if ( { for => 1, foreach => 1 }->{ $first->content() } ) {
1280 6         38 my $next = $first;
1281 6         21 while ( $next = $next->snext_sibling() ) {
1282 18 100       612 $next->isa( 'PPI::Structure::List' )
1283             or next;
1284 6         102 return ! $inner_elem->descendant_of( $next );
1285             }
1286             }
1287             }
1288 0         0 return $TRUE;
1289             }
1290              
1291             # Helper for element_is_in_lexical_scope_after_statement_containing().
1292             # Given and element that represents an assignment or assignment-ish
1293             # statement, and a location, return true if the location is to the right
1294             # of the equals sign, and false otherwise (including the case where
1295             # there is no equals sign). Only the leftmost equals is considered. This
1296             # is a restriction.
1297             sub _location_is_in_right_hand_side_of_assignment {
1298 37     37   2500 my ( $elem, $inner_elem ) = @_;
1299 37         138 my $inner_loc = $inner_elem->location();
1300 37         572 my $kid = $elem->schild( 0 );
1301 37         698 while ( $kid ) {
1302 114 100 100     2767 $kid->isa( 'PPI::Token::Operator' )
1303             and q{=} eq $kid->content()
1304             or next;
1305 28         218 my $l = $kid->location();
1306 28 50       415 $l->[LOCATION_LINE] > $inner_loc->[LOCATION_LINE]
1307             and return;
1308 28 50 66     123 $l->[LOCATION_LINE] == $inner_loc->[LOCATION_LINE]
1309             and $l->[LOCATION_CHARACTER] >= $inner_loc->[LOCATION_CHARACTER]
1310             and return;
1311 28         118 return $inner_elem->descendant_of( $elem );
1312             } continue {
1313 86         313 $kid = $kid->snext_sibling();
1314             }
1315 9         288 return;
1316             }
1317              
1318             # END OF CODE THAT ABSOLUTELY SHOULD NOT BE HERE
1319              
1320             1;
1321              
1322             __END__
1323              
1324             #-----------------------------------------------------------------------------
1325              
1326             =pod
1327              
1328             =for stopwords pre
1329              
1330             =head1 NAME
1331              
1332             Perl::Critic::Policy::Variables::ProhibitUnusedVarsStricter - Don't ask for storage you don't need.
1333              
1334             =head1 AFFILIATION
1335              
1336             This Policy is stand-alone, and is not part of the core
1337             L<Perl::Critic|Perl::Critic>.
1338              
1339             =head1 NOTE
1340              
1341             As of version 0.099_001, the logic that recognizes variables
1342             interpolated into double-quotish strings has been refactored into module
1343             L<PPIx::QuoteLike|PPIx::QuoteLike>.
1344              
1345             =head1 DESCRIPTION
1346              
1347             Unused variables clutter code and require the reader to do mental
1348             bookkeeping to figure out if the variable is actually used or not.
1349              
1350             Right now, this only looks for lexical variables which are unused other
1351             than in the statement that declares them.
1352              
1353             my $x; # not ok, assuming no other appearances.
1354             my @y = (); # not ok, assuming no other appearances.
1355             our $z; # ok, global.
1356             local $w; # ok, global.
1357              
1358             This policy is a variant on the core policy
1359             L<Perl::Critic::Policy::Variables::ProhibitUnusedVariables|Perl::Critic::Policy::Variables::ProhibitUnusedVariables>
1360             which attempts to be more strict in its checking of whether a variable
1361             is used. The specific differences are:
1362              
1363             * An attempt is made to take into account the scope of the declaration.
1364              
1365             * An attempt is made to find variables which are interpolated into
1366             double-quotish strings (including regexes) and here documents.
1367              
1368             * An attempt is made to find variables which are used in regular
1369             expression C<(?{...})> and C<(??{...})> constructions, and in the
1370             replacement portion of C<s/.../.../e>.
1371              
1372             * An attempt is made to find variables which are used in subroutine
1373             signatures.
1374              
1375             This policy intentionally does not report variables as unused if the
1376             code takes a reference to the variable, even if it is otherwise unused.
1377             For example things like
1378              
1379             \( my $foo = 'bar' )
1380             \do{ my $foo => 'bar' }
1381              
1382             will not be reported as a violation even if C<$foo> is otherwise unused.
1383             The reason is that this is an idiom for making a reference to a mutable
1384             string when all you have is an immutable string. This policy does not
1385             check to see if anything is done with the reference.
1386              
1387             This policy also does not detect unused variables declared inside
1388             various odd corners such as
1389              
1390             s///e
1391             qr{(?{...})}
1392             qr{(??{...})}
1393             "@{[ ... ]}"
1394             ( $foo, my $bar ) = ( 1, 2 )
1395             sub ( $foo = $bar ) { ... } # Signature, not prototype
1396              
1397             Most of these are because the PPI parse of the original document does
1398             not include the declarations. The list assignment is missed because PPI
1399             does not parse it as containing a
1400             L<PPI::Statement::Variable|PPI::Statement::Variable>. However, variables
1401             B<used> inside such constructions B<will> be detected.
1402              
1403             =head1 CONFIGURATION
1404              
1405             This policy supports the following configuration items:
1406              
1407             =head2 allow_unused_subroutine_arguments
1408              
1409             By default, this policy prohibits unused subroutine arguments -- that
1410             is, unused variables on the right-hand side of such simple assignments
1411             as
1412              
1413             my ( $foo ) = @_;
1414             my $bar = shift;
1415             my $baz = shift @_;
1416             my $burfle = $_[0];
1417              
1418             If you wish to allow unused variables in this case, you can add a block
1419             like this to your F<.perlcriticrc> file:
1420              
1421             [Variables::ProhibitUnusedVarsStricter]
1422             allow_unused_subroutine_arguments = 1
1423              
1424             =head2 prohibit_reference_only_variables
1425              
1426             By default, this policy allows otherwise-unused variables if the code
1427             takes a reference to the variable when it is created. If you wish to
1428             declare a violation in this case, you can add a block like this to your
1429             F<.perlcriticrc> file:
1430              
1431             [Variables::ProhibitUnusedVarsStricter]
1432             prohibit_reference_only_variables = 1
1433              
1434             =head2 prohibit_returned_lexicals
1435              
1436             By default, this policy allows otherwise-unused lexical variables
1437             (either C<'my'> or C<'state'>) if they are being returned from a
1438             subroutine, under the presumption that they are going to be used as
1439             lvalues by the caller. If you wish to declare a violation in this case,
1440             you can add a block like this to your F<.perlcriticrc> file:
1441              
1442             [Variables::ProhibitUnusedVarsStricter]
1443             prohibit_returned_lexicals = 1
1444              
1445             B<Note> that only explicit C<'return'> statements are covered by this
1446             setting. No attempt is made to detect and allow implicit returns.
1447              
1448             =head2 allow_if_computed_by
1449              
1450             You may wish to allow variables to be unused when computed in certain
1451             ways. For example, you might want to allow place-holder variables in a
1452             list computed by C<stat()> or C<unpack()>. Or you may be doing
1453             end-of-scope detection with something like
1454             C<< my $foo = Scope::Guard->new( \&end_of_scope ) >>. To ignore all
1455             these, you can add a block like this to your F<.perlcriticrc> file:
1456              
1457             [Variables::ProhibitUnusedVarsStricter]
1458             allow_if_computed_by = stat unpack Scope::Guard
1459              
1460             This property takes as its value a whitespace-delimited list of class or
1461             subroutine names.
1462              
1463             As of version 0.115, static method calls are recognized; that is, you
1464             can specify C<< Class->method >> to C<allow_if_computed_by>.
1465              
1466             Nothing complex is done to implement this. the policy simply looks for
1467             the first equals sign, and allows the otherwise-unused variable if the
1468             equals sign is followed by:
1469              
1470             =over
1471              
1472             =item A symbol followed by a dereference and a bareword (e.g. C<< $foo->bar >>;
1473              
1474             =item A bareword, possibly followed by a dereference and a bareword (e.g. C<foo> or C<< foo->bar >>).
1475              
1476             =back
1477              
1478             =head2 allow_state_in_expression
1479              
1480             By default, this policy handles C<state> variables as any other lexical,
1481             and a violation is declared if they appear only in the statement that
1482             declares them.
1483              
1484             One might, however, do something like
1485              
1486             state $foo = compute_foo() or do_something_else();
1487              
1488             In this case, C<compute_foo()> is called only once, but if it returns a
1489             false value C<do_something_else()> will be executed every time this
1490             statement is encountered.
1491              
1492             If you wish to allow such code, you can add a block like this to your
1493             F<.perlcriticrc> file:
1494              
1495             [Variables::ProhibitUnusedVarsStricter]
1496             allow_state_in_expression = 1
1497              
1498             This allows an otherwise-unused state variable if its value appears to
1499             be used in an expression -- that is, if its declaration is followed by a
1500             low-precedence boolean, or one of its ancestors is preceded or followed
1501             by any operator. The latter means that something like
1502              
1503             my $bar = ( state $foo = compute_foo() ) + 42;
1504              
1505             will be accepted.
1506              
1507             This will also cause post-increment and post-decrement to be accepted,
1508             allowing code like
1509              
1510             do_something() unless state $foo++;
1511              
1512             Pre-increment and pre-decrement are ignored, since as of Perl 5.34.0
1513             they are syntax errors.
1514              
1515             =head2 check_catch
1516              
1517             Under ordinary circumstances the C<$err> variable in
1518              
1519             try {
1520             ...
1521             } catch ( $err ) {
1522             ...
1523             }
1524              
1525             will be invisible to this policy because, although it is in fact the
1526             declaration of a lexical variable, the absence of a C<my> means it does
1527             not look like one to L<PPI|PPI>. If you want to test these, you can add
1528             a block like this to your F<.perlcriticrc> file:
1529              
1530             [Variables::ProhibitUnusedVarsStricter]
1531             check_catch = 1
1532              
1533             This option is not on by default because there appears to be no way to
1534             define a C<catch()> block without a variable, whether or not you intend
1535             to use it.
1536              
1537             B<Caveat:> if L<PPI|PPI> ever starts recognizing C<catch( $foo )> as
1538             containing a L<PPI::Statement::Variable|PPI::Statement::Variable>, this
1539             configuration variable will become moot, as the extra logic will no
1540             longer be needed. As soon as I recognize this has happened (and there
1541             B<is> an author test for it) I will document this configuration item as
1542             a no-op, deprecate it, and probably eventually retract it.
1543              
1544             =head1 AVOIDING UNUSED VARIABLES
1545              
1546             There are situations in Perl where eliminating unused variables is
1547             less straightforward than simply deleting them:
1548              
1549             =head2 List Assignments
1550              
1551             This situation typically (I believe) comes up when your code gets handed
1552             a list, and is not interested in all values in the list. You could, of
1553             course, assign the whole thing to an array and then cherry-pick the
1554             array, but there are less-obvious solutions that avoid the extra
1555             assignment.
1556              
1557             For the purpose of this discussion, I will assume code which calls the
1558             C<localtime()> built-in, but is only interested in day, month, and year.
1559             The cut-and-paste implementation (direct from C<perldoc -f localtime>,
1560             or L<https://perldoc.pl/functions/localtime> if you prefer) is:
1561              
1562             # 0 1 2 3 4 5 6 7 8
1563             my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
1564             localtime();
1565              
1566             Now, you can trivially eliminate the variables after C<$year>, but that
1567             still leaves
1568              
1569             # 0 1 2 3 4 5
1570             my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
1571              
1572             with C<$sec>, C<$min>, and C<$hour> assigned-to but unused. There are
1573             two ways I know of to eliminate these:
1574              
1575             =head3 Assign to C<undef>
1576              
1577             On the left-hand side of a list assignment, C<undef> causes the
1578             corresponding right-hand value to be ignored. This makes our example
1579             look like
1580              
1581             # 0 1 2 3 4 5
1582             my (undef,undef,undef,$mday,$mon,$year) = localtime();
1583              
1584             =head3 Slice the Right-Hand Side
1585              
1586             The unwanted values can also be eliminated by slicing the right-hand
1587             side of the assignment. This looks like
1588              
1589             # 3 4 5
1590             my ($mday,$mon,$year) = ( localtime() )[ 3 .. 5 ];
1591              
1592             or, if you prefer,
1593              
1594             # 3 4 5
1595             my ($mday,$mon,$year) = ( localtime() )[ 3, 4, 5 ];
1596              
1597             =head2 Subroutine Signatures
1598              
1599             Subroutine signatures are available via C<use feature 'signatures';>
1600             beginning with Perl 5.20, or via C<use v5.36;> beginning with that
1601             version.
1602              
1603             Unused variables in signatures are specified by just giving the sigil
1604             for the argument. For example,
1605              
1606             sub hi ( $, $who='world', @ ) {
1607             say "Hello, $who";
1608             }
1609              
1610             takes at least two arguments, but only makes use of the second one.
1611              
1612             =head1 SUPPORT
1613              
1614             Support is by the author. Please file bug reports at
1615             L<https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Critic-Policy-Variables-ProhibitUnusedVarsStricter>,
1616             L<https://github.com/trwyant/perl-Perl-Critic-Policy-Variables-ProhibitUnusedVarsStricter/issues>, or in
1617             electronic mail to the author.
1618              
1619             =head1 AUTHOR
1620              
1621             Thomas R. Wyant, III F<wyant at cpan dot org>
1622              
1623             =head1 COPYRIGHT
1624              
1625             Copyright (C) 2012-2022, 2024-2025 Thomas R. Wyant, III
1626              
1627             =head1 LICENSE
1628              
1629             This program is free software; you can redistribute it and/or modify it
1630             under the same terms as Perl 5.10.0. For more details, see the full text
1631             of the licenses in the directory LICENSES.
1632              
1633             This program is distributed in the hope that it will be useful, but
1634             without any warranty; without even the implied warranty of
1635             merchantability or fitness for a particular purpose.
1636              
1637             =cut
1638              
1639             # Local Variables:
1640             # mode: cperl
1641             # cperl-indent-level: 4
1642             # fill-column: 72
1643             # indent-tabs-mode: nil
1644             # c-indentation-style: bsd
1645             # End:
1646             # ex: set ts=8 sts=4 sw=4 tw=72 ft=perl expandtab shiftround :