File Coverage

blib/lib/Perl/Critic/Policy/Variables/ProhibitUnusedVarsStricter.pm
Criterion Covered Total %
statement 401 436 91.9
branch 219 300 73.0
condition 50 79 63.2
subroutine 47 49 95.9
pod 4 5 80.0
total 721 869 82.9


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