File Coverage

blib/lib/PPIx/Utils/Classification.pm
Criterion Covered Total %
statement 178 218 81.6
branch 105 178 58.9
condition 25 53 47.1
subroutine 32 42 76.1
pod 28 28 100.0
total 368 519 70.9


line stmt bran cond sub pod time code
1             package PPIx::Utils::Classification;
2              
3 1     1   120832 use strict;
  1         10  
  1         25  
4 1     1   4 use warnings;
  1         2  
  1         26  
5 1     1   692 use B::Keywords;
  1         1259  
  1         46  
6 1     1   6 use Exporter 'import';
  1         1  
  1         31  
7 1     1   4 use Scalar::Util 'blessed';
  1         2  
  1         183  
8              
9 1     1   387 use PPIx::Utils::Traversal qw(first_arg parse_arg_list);
  1         3  
  1         62  
10             # Functions also used by PPIx::Utils::Traversal
11 1         3243 use PPIx::Utils::_Common qw(
12             is_ppi_expression_or_generic_statement
13             is_ppi_simple_statement
14 1     1   16 );
  1         2  
15              
16             our $VERSION = '0.002';
17              
18             our @EXPORT_OK = qw(
19             is_assignment_operator
20             is_class_name
21             is_function_call
22             is_hash_key
23             is_in_void_context
24             is_included_module_name
25             is_integer
26             is_label_pointer
27             is_method_call
28             is_package_declaration
29             is_perl_bareword
30             is_perl_builtin
31             is_perl_builtin_with_list_context
32             is_perl_builtin_with_multiple_arguments
33             is_perl_builtin_with_no_arguments
34             is_perl_builtin_with_one_argument
35             is_perl_builtin_with_optional_argument
36             is_perl_builtin_with_zero_and_or_one_arguments
37             is_perl_filehandle
38             is_perl_global
39             is_qualified_name
40             is_subroutine_name
41             is_unchecked_call
42             is_ppi_expression_or_generic_statement
43             is_ppi_generic_statement
44             is_ppi_statement_subclass
45             is_ppi_simple_statement
46             is_ppi_constant_element
47             is_subroutine_declaration
48             is_in_subroutine
49             );
50              
51             our %EXPORT_TAGS = (all => [@EXPORT_OK]);
52              
53             # From Perl::Critic::Utils
54             sub _name_for_sub_or_stringified_element {
55 35     35   48 my $elem = shift;
56              
57 35 100 100     187 if ( blessed $elem and $elem->isa('PPI::Statement::Sub') ) {
58 2         8 return $elem->name();
59             }
60              
61 33         82 return "$elem";
62             }
63              
64             my %BUILTINS = map { $_ => 1 } @B::Keywords::Functions;
65              
66             sub is_perl_builtin {
67 4     4 1 3455 my $elem = shift;
68 4 50       12 return undef if !$elem;
69              
70 4         8 return exists $BUILTINS{ _name_for_sub_or_stringified_element($elem) };
71             }
72              
73             my %BAREWORDS = map { $_ => 1 } @B::Keywords::Barewords;
74              
75             sub is_perl_bareword {
76 16     16 1 23 my $elem = shift;
77 16 50       38 return undef if !$elem;
78              
79 16         44 return exists $BAREWORDS{ _name_for_sub_or_stringified_element($elem) };
80             }
81              
82             sub _build_globals_without_sigils {
83             my @globals =
84 1     1   3 map { substr $_, 1 }
  145         195  
85             @B::Keywords::Arrays,
86             @B::Keywords::Hashes,
87             @B::Keywords::Scalars;
88              
89             # Not all of these have sigils
90 1         4 foreach my $filehandle (@B::Keywords::Filehandles) {
91 9         16 (my $stripped = $filehandle) =~ s< \A [*] ><>x;
92 9         15 push @globals, $stripped;
93             }
94              
95 1         26 return @globals;
96             }
97              
98             my %GLOBALS = map { $_ => 1 } _build_globals_without_sigils();
99              
100             sub is_perl_global {
101 7     7 1 3309 my $elem = shift;
102 7 50       32 return undef if !$elem;
103 7         15 my $var_name = "$elem"; #Convert Token::Symbol to string
104 7         31 $var_name =~ s{\A [\$@%*] }{}x; #Chop off the sigil
105 7         40 return exists $GLOBALS{ $var_name };
106             }
107              
108             my %FILEHANDLES = map { $_ => 1 } @B::Keywords::Filehandles;
109              
110             sub is_perl_filehandle {
111 15     15 1 27 my $elem = shift;
112 15 50       40 return undef if !$elem;
113              
114 15         25 return exists $FILEHANDLES{ _name_for_sub_or_stringified_element($elem) };
115             }
116              
117             # egrep '=item.*LIST' perlfunc.pod
118             my %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT =
119             map { $_ => 1 }
120             qw{
121             chmod
122             chown
123             die
124             exec
125             formline
126             grep
127             import
128             join
129             kill
130             map
131             no
132             open
133             pack
134             print
135             printf
136             push
137             reverse
138             say
139             sort
140             splice
141             sprintf
142             syscall
143             system
144             tie
145             unlink
146             unshift
147             use
148             utime
149             warn
150             };
151              
152             sub is_perl_builtin_with_list_context {
153 0     0 1 0 my $elem = shift;
154              
155             return
156             exists
157             $BUILTINS_WHICH_PROVIDE_LIST_CONTEXT{
158 0         0 _name_for_sub_or_stringified_element($elem)
159             };
160             }
161              
162             # egrep '=item.*[A-Z],' perlfunc.pod
163             my %BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS =
164             map { $_ => 1 }
165             qw{
166             accept
167             atan2
168             bind
169             binmode
170             bless
171             connect
172             crypt
173             dbmopen
174             fcntl
175             flock
176             gethostbyaddr
177             getnetbyaddr
178             getpriority
179             getservbyname
180             getservbyport
181             getsockopt
182             index
183             ioctl
184             link
185             listen
186             mkdir
187             msgctl
188             msgget
189             msgrcv
190             msgsnd
191             open
192             opendir
193             pipe
194             read
195             recv
196             rename
197             rindex
198             seek
199             seekdir
200             select
201             semctl
202             semget
203             semop
204             send
205             setpgrp
206             setpriority
207             setsockopt
208             shmctl
209             shmget
210             shmread
211             shmwrite
212             shutdown
213             socket
214             socketpair
215             splice
216             split
217             substr
218             symlink
219             sysopen
220             sysread
221             sysseek
222             syswrite
223             truncate
224             unpack
225             vec
226             waitpid
227             },
228             keys %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT;
229              
230             sub is_perl_builtin_with_multiple_arguments {
231 0     0 1 0 my $elem = shift;
232              
233             return
234             exists
235             $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{
236 0         0 _name_for_sub_or_stringified_element($elem)
237             };
238             }
239              
240             my %BUILTINS_WHICH_TAKE_NO_ARGUMENTS =
241             map { $_ => 1 }
242             qw{
243             endgrent
244             endhostent
245             endnetent
246             endprotoent
247             endpwent
248             endservent
249             fork
250             format
251             getgrent
252             gethostent
253             getlogin
254             getnetent
255             getppid
256             getprotoent
257             getpwent
258             getservent
259             setgrent
260             setpwent
261             split
262             time
263             times
264             wait
265             wantarray
266             };
267              
268             sub is_perl_builtin_with_no_arguments {
269 0     0 1 0 my $elem = shift;
270              
271             return
272             exists
273             $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{
274 0         0 _name_for_sub_or_stringified_element($elem)
275             };
276             }
277              
278             my %BUILTINS_WHICH_TAKE_ONE_ARGUMENT =
279             map { $_ => 1 }
280             qw{
281             closedir
282             dbmclose
283             delete
284             each
285             exists
286             fileno
287             getgrgid
288             getgrnam
289             gethostbyname
290             getnetbyname
291             getpeername
292             getpgrp
293             getprotobyname
294             getprotobynumber
295             getpwnam
296             getpwuid
297             getsockname
298             goto
299             keys
300             local
301             prototype
302             readdir
303             readline
304             readpipe
305             rewinddir
306             scalar
307             sethostent
308             setnetent
309             setprotoent
310             setservent
311             telldir
312             tied
313             untie
314             values
315             };
316              
317             sub is_perl_builtin_with_one_argument {
318 0     0 1 0 my $elem = shift;
319              
320             return
321             exists
322             $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{
323 0         0 _name_for_sub_or_stringified_element($elem)
324             };
325             }
326              
327             my %BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT =
328             map { $_ => 1 }
329             grep { not exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $_ } }
330             grep { not exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $_ } }
331             grep { not exists $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{ $_ } }
332             @B::Keywords::Functions;
333              
334             sub is_perl_builtin_with_optional_argument {
335 0     0 1 0 my $elem = shift;
336              
337             return
338             exists
339             $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{
340 0         0 _name_for_sub_or_stringified_element($elem)
341             };
342             }
343              
344             sub is_perl_builtin_with_zero_and_or_one_arguments {
345 0     0 1 0 my $elem = shift;
346              
347 0 0       0 return undef if not $elem;
348              
349 0         0 my $name = _name_for_sub_or_stringified_element($elem);
350              
351             return (
352             exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $name }
353             or exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $name }
354 0   0     0 or exists $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{ $name }
355             );
356             }
357              
358             sub is_qualified_name {
359 0     0 1 0 my $name = shift;
360              
361 0 0       0 return undef if not $name;
362              
363 0         0 return index ( $name, q{::} ) >= 0;
364             }
365              
366             sub _is_followed_by_parens {
367 20     20   27 my $elem = shift;
368 20 50       39 return undef if !$elem;
369              
370 20   100     47 my $sibling = $elem->snext_sibling() || return undef;
371 18         358 return $sibling->isa('PPI::Structure::List');
372             }
373              
374             sub is_hash_key {
375 20     20 1 12067 my $elem = shift;
376 20 50       55 return undef if !$elem;
377              
378             #If followed by an argument list, then its a function call, not a literal
379 20 100       39 return undef if _is_followed_by_parens($elem);
380              
381             #Check curly-brace style: $hash{foo} = bar;
382 12         74 my $parent = $elem->parent();
383 12 50       54 return undef if !$parent;
384 12         33 my $grandparent = $parent->parent();
385 12 50       51 return undef if !$grandparent;
386 12 100       35 return 1 if $grandparent->isa('PPI::Structure::Subscript');
387              
388              
389             #Check declarative style: %hash = (foo => bar);
390 10         49 my $sib = $elem->snext_sibling();
391 10 50       166 return undef if !$sib;
392 10 50 33     46 return 1 if $sib->isa('PPI::Token::Operator') && $sib eq '=>';
393              
394 10         30 return undef;
395             }
396              
397             sub is_included_module_name {
398 15     15 1 24 my $elem = shift;
399 15 50       39 return undef if !$elem;
400 15         33 my $stmnt = $elem->statement();
401 15 50       152 return undef if !$stmnt;
402 15 50       119 return undef if !$stmnt->isa('PPI::Statement::Include');
403 0         0 return $stmnt->schild(1) == $elem;
404             }
405              
406             sub is_integer {
407 0     0 1 0 my ($value) = @_;
408 0 0       0 return 0 if not defined $value;
409              
410 0         0 return $value =~ m{ \A [+-]? [0-9]+ \z }x;
411             }
412              
413             sub is_label_pointer {
414 14     14 1 17 my $elem = shift;
415 14 50       31 return undef if !$elem;
416              
417 14         26 my $statement = $elem->statement();
418 14 50       149 return undef if !$statement;
419              
420 14         27 my $psib = $elem->sprevious_sibling();
421 14 100       232 return undef if !$psib;
422              
423 2   66     11 return $statement->isa('PPI::Statement::Break')
424             && $psib =~ m/(?:redo|goto|next|last)/x;
425             }
426              
427             sub _is_dereference_operator {
428 30     30   541 my $elem = shift;
429 30 100       84 return undef if !$elem;
430              
431 18   66     68 return $elem->isa('PPI::Token::Operator') && $elem eq q{->};
432             }
433              
434             sub is_method_call {
435 15     15 1 23 my $elem = shift;
436 15 50       32 return undef if !$elem;
437              
438 15         52 return _is_dereference_operator( $elem->sprevious_sibling() );
439             }
440              
441             sub is_class_name {
442 15     15 1 19 my $elem = shift;
443 15 50       31 return undef if !$elem;
444              
445 15   33     39 return _is_dereference_operator( $elem->snext_sibling() )
446             && !_is_dereference_operator( $elem->sprevious_sibling() );
447             }
448              
449             sub is_package_declaration {
450 15     15 1 19 my $elem = shift;
451 15 50       36 return undef if !$elem;
452 15         38 my $stmnt = $elem->statement();
453 15 50       201 return undef if !$stmnt;
454 15 50       75 return undef if !$stmnt->isa('PPI::Statement::Package');
455 0         0 return $stmnt->schild(1) == $elem;
456             }
457              
458             sub is_subroutine_name {
459 17     17 1 2647 my $elem = shift;
460 17 50       43 return undef if !$elem;
461 17         38 my $sib = $elem->sprevious_sibling();
462 17 100       266 return undef if !$sib;
463 5         16 my $stmnt = $elem->statement();
464 5 50       61 return undef if !$stmnt;
465 5   66     26 return $stmnt->isa('PPI::Statement::Sub') && $sib eq 'sub';
466             }
467              
468             sub is_function_call {
469 16 50   16 1 1886 my $elem = shift or return undef;
470              
471 16 100       36 return undef if is_perl_bareword($elem);
472 15 50       103 return undef if is_perl_filehandle($elem);
473 15 50       169 return undef if is_package_declaration($elem);
474 15 50       31 return undef if is_included_module_name($elem);
475 15 50       37 return undef if is_method_call($elem);
476 15 50       53 return undef if is_class_name($elem);
477 15 100       81 return undef if is_subroutine_name($elem);
478 14 50       36 return undef if is_label_pointer($elem);
479 14 50       34 return undef if is_hash_key($elem);
480              
481 14         69 return 1;
482             }
483              
484             sub is_in_void_context {
485 0     0 1 0 my ($token) = @_;
486              
487             # If part of a collective, can't be void.
488 0 0       0 return undef if $token->sprevious_sibling();
489              
490 0         0 my $parent = $token->statement()->parent();
491 0 0       0 if ($parent) {
492 0 0       0 return undef if $parent->isa('PPI::Structure::List');
493 0 0       0 return undef if $parent->isa('PPI::Structure::For');
494 0 0       0 return undef if $parent->isa('PPI::Structure::Condition');
495 0 0       0 return undef if $parent->isa('PPI::Structure::Constructor');
496 0 0       0 return undef if $parent->isa('PPI::Structure::Subscript');
497              
498 0         0 my $grand_parent = $parent->parent();
499 0 0       0 if ($grand_parent) {
500             return undef if
501 0 0 0     0 $parent->isa('PPI::Structure::Block')
502             and not $grand_parent->isa('PPI::Statement::Compound');
503             }
504             }
505              
506 0         0 return 1;
507             }
508              
509             my %ASSIGNMENT_OPERATORS = map { $_ => 1 } qw( = **= += -= .= *= /= %= x= &= |= ^= <<= >>= &&= ||= //= );
510              
511             sub is_assignment_operator {
512 29     29 1 12088 my $elem = shift;
513              
514 29         106 return exists $ASSIGNMENT_OPERATORS{ $elem };
515             }
516              
517             sub is_unchecked_call {
518 14     14 1 44396 my $elem = shift;
519              
520 14 50       47 return undef if not is_function_call( $elem );
521              
522             # check to see if there's an '=' or 'unless' or something before this.
523 14 100       32 if( my $sib = $elem->sprevious_sibling() ){
524 2 50       49 return undef if $sib;
525             }
526              
527              
528 12 50       151 if( my $statement = $elem->statement() ){
529              
530             # "open or die" is OK.
531             # We can't check snext_sibling for 'or' since the next siblings are an
532             # unknown number of arguments to the system call. Instead, check all of
533             # the elements to this statement to see if we find 'or' or '||'.
534              
535             my $or_operators = sub {
536 90     90   1006 my (undef, $elem) = @_;
537 90 100       222 return undef if not $elem->isa('PPI::Token::Operator');
538 13 100 66     27 return undef if $elem ne q{or} && $elem ne q{||};
539 1         16 return 1;
540 12         158 };
541              
542 12 100       44 return undef if $statement->find( $or_operators );
543              
544              
545 11 50       99 if( my $parent = $elem->statement()->parent() ){
546              
547             # Check if we're in an if( open ) {good} else {bad} condition
548 11 50       185 return undef if $parent->isa('PPI::Structure::Condition');
549              
550             # Return val could be captured in data structure and checked later
551 11 50       57 return undef if $parent->isa('PPI::Structure::Constructor');
552              
553             # "die if not ( open() )" - It's in list context.
554 11 100       62 if ( $parent->isa('PPI::Structure::List') ) {
555 6 100       62 if( my $uncle = $parent->sprevious_sibling() ){
556 1 50       32 return undef if $uncle;
557             }
558             }
559             }
560             }
561              
562 10 100       105 return undef if _is_fatal($elem);
563              
564             # Otherwise, return. this system call is unchecked.
565 3         25 return 1;
566             }
567              
568             # Based upon autodie 2.10.
569             my %AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP = (
570             # Map builtins to themselves.
571             (
572             map { ($_ => { $_ => 1 }) }
573             qw<
574             accept bind binmode chdir chmod close closedir connect
575             dbmclose dbmopen exec fcntl fileno flock fork getsockopt ioctl
576             link listen mkdir msgctl msgget msgrcv msgsnd open opendir
577             pipe read readlink recv rename rmdir seek semctl semget semop
578             send setsockopt shmctl shmget shmread shutdown socketpair
579             symlink sysopen sysread sysseek system syswrite truncate umask
580             unlink
581             >
582             ),
583              
584             # Generate these using tools/dump-autodie-tag-contents
585             ':threads' => { map { $_ => 1 } qw< fork > },
586             ':system' => { map { $_ => 1 } qw< exec system > },
587             ':dbm' => { map { $_ => 1 } qw< dbmclose dbmopen > },
588             ':semaphore' => { map { $_ => 1 } qw< semctl semget semop > },
589             ':shm' => { map { $_ => 1 } qw< shmctl shmget shmread > },
590             ':msg' => { map { $_ => 1 } qw< msgctl msgget msgrcv msgsnd > },
591             ':file' => {
592             map { $_ => 1 }
593             qw<
594             binmode chmod close fcntl fileno flock ioctl open sysopen
595             truncate
596             >
597             },
598             ':filesys' => {
599             map { $_ => 1 }
600             qw<
601             chdir closedir link mkdir opendir readlink rename rmdir
602             symlink umask unlink
603             >
604             },
605             ':ipc' => {
606             map { $_ => 1 }
607             qw<
608             msgctl msgget msgrcv msgsnd pipe semctl semget semop shmctl
609             shmget shmread
610             >
611             },
612             ':socket' => {
613             map { $_ => 1 }
614             qw<
615             accept bind connect getsockopt listen recv send setsockopt
616             shutdown socketpair
617             >
618             },
619             ':io' => {
620             map { $_ => 1 }
621             qw<
622             accept bind binmode chdir chmod close closedir connect
623             dbmclose dbmopen fcntl fileno flock getsockopt ioctl link
624             listen mkdir msgctl msgget msgrcv msgsnd open opendir pipe
625             read readlink recv rename rmdir seek semctl semget semop send
626             setsockopt shmctl shmget shmread shutdown socketpair symlink
627             sysopen sysread sysseek syswrite truncate umask unlink
628             >
629             },
630             ':default' => {
631             map { $_ => 1 }
632             qw<
633             accept bind binmode chdir chmod close closedir connect
634             dbmclose dbmopen fcntl fileno flock fork getsockopt ioctl link
635             listen mkdir msgctl msgget msgrcv msgsnd open opendir pipe
636             read readlink recv rename rmdir seek semctl semget semop send
637             setsockopt shmctl shmget shmread shutdown socketpair symlink
638             sysopen sysread sysseek syswrite truncate umask unlink
639             >
640             },
641             ':all' => {
642             map { $_ => 1 }
643             qw<
644             accept bind binmode chdir chmod close closedir connect
645             dbmclose dbmopen exec fcntl fileno flock fork getsockopt ioctl
646             link listen mkdir msgctl msgget msgrcv msgsnd open opendir
647             pipe read readlink recv rename rmdir seek semctl semget semop
648             send setsockopt shmctl shmget shmread shutdown socketpair
649             symlink sysopen sysread sysseek system syswrite truncate umask
650             unlink
651             >
652             },
653             );
654              
655             sub _is_fatal {
656 10     10   18 my ($elem) = @_;
657              
658 10         28 my $top = $elem->top();
659 10 50       126 return undef if not $top->isa('PPI::Document');
660              
661 10         21 my $includes = $top->find('PPI::Statement::Include');
662 10 100       7060 return undef if not $includes;
663              
664 8         16 for my $include (@{$includes}) {
  8         19  
665 8 50       30 next if 'use' ne $include->type();
666              
667 8 100       205 if ('Fatal' eq $include->module()) {
    100          
    50          
668 2         45 my @args = parse_arg_list($include->schild(1));
669 2         4 foreach my $arg (@args) {
670 2 50 33     20 return 1 if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string();
671             }
672             }
673             elsif ('Fatal::Exception' eq $include->module()) {
674 2         89 my @args = parse_arg_list($include->schild(1));
675 2         3 shift @args; # skip exception class name
676 2         5 foreach my $arg (@args) {
677 2 50 33     13 return 1 if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string();
678             }
679             }
680             elsif ('autodie' eq $include->pragma()) {
681 4         249 return _is_covered_by_autodie($elem, $include);
682             }
683             }
684              
685 0         0 return undef;
686             }
687              
688             sub _is_covered_by_autodie {
689 4     4   10 my ($elem, $include) = @_;
690              
691 4         9 my $autodie = $include->schild(1);
692 4         53 my @args = parse_arg_list($autodie);
693 4         10 my $first_arg = first_arg($autodie);
694              
695             # The first argument to any `use` pragma could be a version number.
696             # If so, then we just discard it. We only want the arguments after it.
697 4 50 33     28 if ($first_arg and $first_arg->isa('PPI::Token::Number')){ shift @args };
  0         0  
698              
699 4 100       8 if (@args) {
700 3         6 foreach my $arg (@args) {
701             my $builtins =
702             $AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP{
703 4         18 $arg->[0]->string
704             };
705              
706 4 100 66     32 return 1 if $builtins and $builtins->{$elem->content()};
707             }
708             }
709             else {
710             my $builtins =
711 1         3 $AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP{':default'};
712              
713 1 50 33     6 return 1 if $builtins and $builtins->{$elem->content()};
714             }
715              
716 1         9 return undef;
717             }
718             # End from Perl::Critic::Utils
719              
720             # From Perl::Critic::Utils::PPI
721             sub is_ppi_generic_statement {
722 29     29 1 267 my $element = shift;
723              
724 29         75 my $element_class = blessed($element);
725              
726 29 100       57 return undef if not $element_class;
727 28 100       83 return undef if not $element->isa('PPI::Statement');
728              
729 23         81 return $element_class eq 'PPI::Statement';
730             }
731              
732             sub is_ppi_statement_subclass {
733 16     16 1 261 my $element = shift;
734              
735 16         42 my $element_class = blessed($element);
736              
737 16 100       33 return undef if not $element_class;
738 15 100       48 return undef if not $element->isa('PPI::Statement');
739              
740 14         47 return $element_class ne 'PPI::Statement';
741             }
742              
743             sub is_ppi_constant_element {
744 0 0   0 1 0 my $element = shift or return undef;
745              
746 0 0       0 blessed( $element ) or return undef;
747              
748             # TODO implement here documents once PPI::Token::HereDoc grows the
749             # necessary PPI::Token::Quote interface.
750             return
751 0   0     0 $element->isa( 'PPI::Token::Number' )
752             || $element->isa( 'PPI::Token::Quote::Literal' )
753             || $element->isa( 'PPI::Token::Quote::Single' )
754             || $element->isa( 'PPI::Token::QuoteLike::Words' )
755             || (
756             $element->isa( 'PPI::Token::Quote::Double' )
757             || $element->isa( 'PPI::Token::Quote::Interpolate' ) )
758             && $element->string() !~ m< (?: \A | [^\\] ) (?: \\\\)* [\$\@] >smx
759             ;
760             }
761              
762             sub is_subroutine_declaration {
763 16     16 1 7008 my $element = shift;
764              
765 16 100       44 return undef if not $element;
766              
767 15 100       75 return 1 if $element->isa('PPI::Statement::Sub');
768              
769 13 100       30 if ( is_ppi_generic_statement($element) ) {
770 4         14 my $first_element = $element->first_element();
771              
772 4 100 66     39 return 1 if
      66        
773             $first_element
774             and $first_element->isa('PPI::Token::Word')
775             and $first_element->content() eq 'sub';
776             }
777              
778 10         41 return undef;
779             }
780              
781             sub is_in_subroutine {
782 5     5 1 6987 my ($element) = @_;
783              
784 5 100       21 return undef if not $element;
785 3 50       8 return 1 if is_subroutine_declaration($element);
786              
787 3         16 while ( $element = $element->parent() ) {
788 7 100       34 return 1 if is_subroutine_declaration($element);
789             }
790              
791 1         8 return undef;
792             }
793             # End from Perl::Critic::Utils::PPI
794              
795             1;
796              
797             =head1 NAME
798              
799             PPIx::Utils::Classification - Utility functions for classification of PPI
800             elements
801              
802             =head1 SYNOPSIS
803              
804             use PPIx::Utils::Classification ':all';
805              
806             =head1 DESCRIPTION
807              
808             This package is a component of L that contains functions for
809             classification of L elements.
810              
811             =head1 FUNCTIONS
812              
813             All functions can be imported by name, or with the tag C<:all>.
814              
815             =head2 is_assignment_operator
816              
817             my $bool = is_assignment_operator($element);
818              
819             Given a L or a string, returns true if that
820             token represents one of the assignment operators (e.g.
821             C<= &&= ||= //= += -=> etc.).
822              
823             =head2 is_perl_global
824              
825             my $bool = is_perl_global($element);
826              
827             Given a L or a string, returns true if that token
828             represents one of the global variables provided by the L
829             module, or one of the builtin global variables like C<%SIG>, C<%ENV>,
830             or C<@ARGV>. The sigil on the symbol is ignored, so things like
831             C<$ARGV> or C<$ENV> will still return true.
832              
833             =head2 is_perl_builtin
834              
835             my $bool = is_perl_builtin($element);
836              
837             Given a L, L, or string,
838             returns true if that token represents a call to any of the builtin
839             functions defined in Perl 5.8.8.
840              
841             =head2 is_perl_bareword
842              
843             my $bool = is_perl_bareword($element);
844              
845             Given a L, L, or string,
846             returns true if that token represents a bareword (e.g. "if", "else",
847             "sub", "package") defined in Perl 5.8.8.
848              
849             =head2 is_perl_filehandle
850              
851             my $bool = is_perl_filehandle($element);
852              
853             Given a L, or string, returns true if that token
854             represents one of the global filehandles (e.g. C, C,
855             C, C) that are defined in Perl 5.8.8. Note that this
856             function will return false if given a filehandle that is represented
857             as a typeglob (e.g. C<*STDIN>)
858              
859             =head2 is_perl_builtin_with_list_context
860              
861             my $bool = is_perl_builtin_with_list_context($element);
862              
863             Given a L, L, or string,
864             returns true if that token represents a call to any of the builtin
865             functions defined in Perl 5.8.8 that provide a list context to the
866             following tokens.
867              
868             =head2 is_perl_builtin_with_multiple_arguments
869              
870             my $bool = is_perl_builtin_with_multiple_arguments($element);
871              
872             Given a L, L, or string,
873             returns true if that token represents a call to any of the builtin
874             functions defined in Perl 5.8.8 that B take multiple arguments.
875              
876             =head2 is_perl_builtin_with_no_arguments
877              
878             my $bool = is_perl_builtin_with_no_arguments($element);
879              
880             Given a L, L, or string,
881             returns true if that token represents a call to any of the builtin
882             functions defined in Perl 5.8.8 that B take any arguments.
883              
884             =head2 is_perl_builtin_with_one_argument
885              
886             my $bool = is_perl_builtin_with_one_argument($element);
887              
888             Given a L, L, or string,
889             returns true if that token represents a call to any of the builtin
890             functions defined in Perl 5.8.8 that takes B
891             argument.
892              
893             =head2 is_perl_builtin_with_optional_argument
894              
895             my $bool = is_perl_builtin_with_optional_argument($element);
896              
897             Given a L, L, or string,
898             returns true if that token represents a call to any of the builtin
899             functions defined in Perl 5.8.8 that takes B
900             argument.
901              
902             The sets of values for which
903             L,
904             L,
905             L, and
906             L return true are disjoint
907             and their union is precisely the set of values that
908             L will return true for.
909              
910             =head2 is_perl_builtin_with_zero_and_or_one_arguments
911              
912             my $bool = is_perl_builtin_with_zero_and_or_one_arguments($element);
913              
914             Given a L, L, or string,
915             returns true if that token represents a call to any of the builtin
916             functions defined in Perl 5.8.8 that takes no and/or one argument.
917              
918             Returns true if any of L,
919             L, and
920             L returns true.
921              
922             =head2 is_qualified_name
923              
924             my $bool = is_qualified_name($name);
925              
926             Given a string, L, or L, answers
927             whether it has a module component, i.e. contains "::".
928              
929             =head2 is_hash_key
930              
931             my $bool = is_hash_key($element);
932              
933             Given a L, returns true if the element is a literal hash
934             key. PPI doesn't distinguish between regular barewords (like keywords
935             or subroutine calls) and barewords in hash subscripts (which are
936             considered literal). So this subroutine is useful if your Policy is
937             searching for L elements and you want to filter out
938             the hash subscript variety. In both of the following examples, "foo"
939             is considered a hash key:
940              
941             $hash1{foo} = 1;
942             %hash2 = (foo => 1);
943              
944             But if the bareword is followed by an argument list, then perl treats
945             it as a function call. So in these examples, "foo" is B
946             considered a hash key:
947              
948             $hash1{ foo() } = 1;
949             &hash2 = (foo() => 1);
950              
951             =head2 is_included_module_name
952              
953             my $bool = is_included_module_name($element);
954              
955             Given a L, returns true if the element is the name
956             of a module that is being included via C, C, or C.
957              
958             =head2 is_integer
959              
960             my $bool = is_integer($value);
961              
962             Answers whether the parameter, as a string, looks like an integral
963             value.
964              
965             =head2 is_class_name
966              
967             my $bool = is_class_name($element);
968              
969             Given a L, returns true if the element that
970             immediately follows this element is the dereference operator "->".
971             When a bareword has a "->" on the B side, it usually means that
972             it is the name of the class (from which a method is being called).
973              
974             =head2 is_label_pointer
975              
976             my $bool = is_label_pointer($element);
977              
978             Given a L, returns true if the element is the label
979             in a C, C, C, or C statement. Note this is
980             not the same thing as the label declaration.
981              
982             =head2 is_method_call
983              
984             my $bool = is_method_call($element);
985              
986             Given a L, returns true if the element that
987             immediately precedes this element is the dereference operator "->".
988             When a bareword has a "->" on the B side, it usually means that
989             it is the name of a method (that is being called from a class).
990              
991             =head2 is_package_declaration
992              
993             my $bool = is_package_declaration($element);
994              
995             Given a L, returns true if the element is the name
996             of a package that is being declared.
997              
998             =head2 is_subroutine_name
999              
1000             my $bool = is_subroutine_name($element);
1001              
1002             Given a L, returns true if the element is the name
1003             of a subroutine declaration. This is useful for distinguishing
1004             barewords and from function calls from subroutine declarations.
1005              
1006             =head2 is_function_call
1007              
1008             my $bool = is_function_call($element);
1009              
1010             Given a L returns true if the element appears to be
1011             call to a static function. Specifically, this function returns true
1012             if L, L, L,
1013             L, L,
1014             L, L, L and
1015             L all return false for the given element.
1016              
1017             =head2 is_in_void_context
1018              
1019             my $bool = is_in_void_context($token);
1020              
1021             Given a L, answer whether it appears to be in a void
1022             context.
1023              
1024             =head2 is_unchecked_call
1025              
1026             my $bool = is_unchecked_call($element);
1027              
1028             Given a L, test to see if it contains a function call
1029             whose return value is not checked.
1030              
1031             =head2 is_ppi_expression_or_generic_statement
1032              
1033             my $bool = is_ppi_expression_or_generic_statement($element);
1034              
1035             Answers whether the parameter is an expression or an undifferentiated
1036             statement. I.e. the parameter either is a
1037             L or the class of the parameter is
1038             L and not one of its subclasses other than
1039             C.
1040              
1041             =head2 is_ppi_generic_statement
1042              
1043             my $bool = is_ppi_generic_statement($element);
1044              
1045             Answers whether the parameter is an undifferentiated statement, i.e.
1046             the parameter is a L but not one of its subclasses.
1047              
1048             =head2 is_ppi_statement_subclass
1049              
1050             my $bool = is_ppi_statement_subclass($element);
1051              
1052             Answers whether the parameter is a specialized statement, i.e. the
1053             parameter is a L but the class of the parameter is not
1054             L.
1055              
1056             =head2 is_ppi_simple_statement
1057              
1058             my $bool = is_ppi_simple_statement($element);
1059              
1060             Answers whether the parameter represents a simple statement, i.e. whether the
1061             parameter is a L, L,
1062             L, L,
1063             L, or L.
1064              
1065             =head2 is_ppi_constant_element
1066              
1067             my $bool = is_ppi_constant_element($element);
1068              
1069             Answers whether the parameter represents a constant value, i.e. whether the
1070             parameter is a L, L,
1071             L, or L, or
1072             is a L or L
1073             which does not in fact contain any interpolated variables.
1074              
1075             This subroutine does B interpret any form of here document as a constant
1076             value, and may not until L acquires the relevant
1077             portions of the L interface.
1078              
1079             This subroutine also does B interpret entities created by the
1080             L module (or similar) or the L pragma as constants.
1081              
1082             =head2 is_subroutine_declaration
1083              
1084             my $bool = is_subroutine_declaration($element);
1085              
1086             Is the parameter a subroutine declaration, named or not?
1087              
1088             =head2 is_in_subroutine
1089              
1090             my $bool = is_in_subroutine($element);
1091              
1092             Is the parameter a subroutine or inside one?
1093              
1094             =head1 BUGS
1095              
1096             Report any issues on the public bugtracker.
1097              
1098             =head1 AUTHOR
1099              
1100             Dan Book
1101              
1102             Code originally from L by Jeffrey Ryan Thalhammer
1103             and L by
1104             Elliot Shank
1105              
1106             =head1 COPYRIGHT AND LICENSE
1107              
1108             This software is copyright (c) 2005-2011 Imaginative Software Systems,
1109             2007-2011 Elliot Shank, 2017 Dan Book.
1110              
1111             This is free software; you can redistribute it and/or modify it under
1112             the same terms as the Perl 5 programming language system itself.
1113              
1114             =head1 SEE ALSO
1115              
1116             L, L