Login
Self-compliance with ProhibitUnrestrictedNoCritic
[gknop/Perl-Critic.git] / lib / Perl / Critic / Utils.pm
CommitLineData
6036a254 1##############################################################################
39cd321a
JRT
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
6036a254 6##############################################################################
39cd321a 7
9f12283e
ES
8# NOTE: This module is way too large. Please think about adding new
9# functionality into a P::C::Utils::* module instead.
10
59b05e08
JRT
11package Perl::Critic::Utils;
12
df6dee2b 13use 5.006001;
59b05e08
JRT
14use strict;
15use warnings;
c680a9c9 16use Readonly;
c948abe5 17
410cf90b 18use File::Spec qw();
c948abe5 19use Scalar::Util qw( blessed );
e2d4c0f0 20use B::Keywords qw();
cbb58756 21use PPI::Token::Quote::Single;
c948abe5 22
4b1bd955 23use Perl::Critic::Exception::Fatal::Generic qw{ throw_generic };
329eea9a
ES
24use Perl::Critic::Utils::PPI qw< is_ppi_expression_or_generic_statement >;
25
59b05e08
JRT
26use base 'Exporter';
27
173667ce 28our $VERSION = '1.093_01';
59b05e08 29
6036a254 30#-----------------------------------------------------------------------------
bbf4108c 31# Exportable symbols here.
1fe8e187 32
c680a9c9 33Readonly::Array our @EXPORT_OK => qw(
dc93df4f
JRT
34 $TRUE
35 $FALSE
36
e2d4c0f0
JRT
37 $POLICY_NAMESPACE
38
dc93df4f
JRT
39 $SEVERITY_HIGHEST
40 $SEVERITY_HIGH
41 $SEVERITY_MEDIUM
42 $SEVERITY_LOW
43 $SEVERITY_LOWEST
0bcb38c0 44 @SEVERITY_NAMES
dc93df4f 45
738830ba
ES
46 $DEFAULT_VERBOSITY
47 $DEFAULT_VERBOSITY_WITH_FILE_NAME
48
dc93df4f
JRT
49 $COLON
50 $COMMA
51 $DQUOTE
52 $EMPTY
53 $FATCOMMA
54 $PERIOD
55 $PIPE
56 $QUOTE
68a933bc 57 $BACKTICK
dc93df4f
JRT
58 $SCOLON
59 $SPACE
a609ec83
ES
60 $SLASH
61 $BSLASH
310e7cf9
ES
62 $LEFT_PAREN
63 $RIGHT_PAREN
6f31806e 64
70f3f307
ES
65 all_perl_files
66 find_keywords
67 first_arg
68 hashify
69 interpolate
70 is_class_name
71 is_function_call
72 is_hash_key
73 is_in_void_context
74 is_included_module_name
75 is_integer
76 is_label_pointer
77 is_method_call
78 is_package_declaration
79 is_perl_bareword
80 is_perl_builtin
81 is_perl_builtin_with_list_context
82 is_perl_builtin_with_multiple_arguments
83 is_perl_builtin_with_no_arguments
84 is_perl_builtin_with_one_argument
85 is_perl_builtin_with_optional_argument
86 is_perl_builtin_with_zero_and_or_one_arguments
87 is_perl_filehandle
88 is_perl_global
89 is_qualified_name
90 is_script
91 is_subroutine_name
92 is_unchecked_call
93 is_valid_numeric_verbosity
94 parse_arg_list
95 policy_long_name
96 policy_short_name
97 precedence_of
98 severity_to_number
99 shebang_line
100 split_nodes_on_comma
101 verbosity_to_format
102 words_from_string
bbf4108c
ES
103);
104
7cb05702
JRT
105
106# Note: this is deprecated.
c680a9c9 107Readonly::Array our @EXPORT => @EXPORT_OK; ## no critic (ProhibitAutomaticExport)
7cb05702 108
5feaec1d 109
c680a9c9 110Readonly::Hash our %EXPORT_TAGS => (
bbf4108c
ES
111 all => [ @EXPORT_OK ],
112 booleans => [ qw{ $TRUE $FALSE } ],
113 severities => [
114 qw{
115 $SEVERITY_HIGHEST
116 $SEVERITY_HIGH
117 $SEVERITY_MEDIUM
118 $SEVERITY_LOW
119 $SEVERITY_LOWEST
120 @SEVERITY_NAMES
121 }
122 ],
123 characters => [
124 qw{
125 $COLON
126 $COMMA
127 $DQUOTE
128 $EMPTY
129 $FATCOMMA
130 $PERIOD
131 $PIPE
132 $QUOTE
68a933bc 133 $BACKTICK
bbf4108c
ES
134 $SCOLON
135 $SPACE
136 $SLASH
137 $BSLASH
310e7cf9
ES
138 $LEFT_PAREN
139 $RIGHT_PAREN
bbf4108c
ES
140 }
141 ],
142 classification => [
143 qw{
70f3f307
ES
144 is_class_name
145 is_function_call
146 is_hash_key
147 is_included_module_name
148 is_integer
149 is_label_pointer
150 is_method_call
151 is_package_declaration
152 is_perl_bareword
153 is_perl_builtin
154 is_perl_filehandle
155 is_perl_global
156 is_perl_builtin_with_list_context
157 is_perl_builtin_with_multiple_arguments
158 is_perl_builtin_with_no_arguments
159 is_perl_builtin_with_one_argument
160 is_perl_builtin_with_optional_argument
161 is_perl_builtin_with_zero_and_or_one_arguments
162 is_qualified_name
163 is_script
164 is_subroutine_name
165 is_unchecked_call
166 is_valid_numeric_verbosity
bbf4108c
ES
167 }
168 ],
70f3f307
ES
169 data_conversion => [ qw{ hashify words_from_string interpolate } ],
170 ppi => [ qw{ first_arg parse_arg_list } ],
171 internal_lookup => [ qw{ severity_to_number verbosity_to_format } ],
172 language => [ qw{ precedence_of } ],
173 deprecated => [ qw{ find_keywords } ],
59b05e08
JRT
174);
175
6036a254 176#-----------------------------------------------------------------------------
59b05e08 177
c680a9c9 178Readonly::Scalar our $POLICY_NAMESPACE => 'Perl::Critic::Policy';
1fe8e187 179
6036a254 180#-----------------------------------------------------------------------------
1fe8e187 181
c680a9c9
ES
182Readonly::Scalar our $SEVERITY_HIGHEST => 5;
183Readonly::Scalar our $SEVERITY_HIGH => 4;
184Readonly::Scalar our $SEVERITY_MEDIUM => 3;
185Readonly::Scalar our $SEVERITY_LOW => 2;
186Readonly::Scalar our $SEVERITY_LOWEST => 1;
dff08b70 187
6036a254 188#-----------------------------------------------------------------------------
6b4a61e9 189
c680a9c9
ES
190Readonly::Scalar our $COMMA => q{,};
191Readonly::Scalar our $FATCOMMA => q{=>};
192Readonly::Scalar our $COLON => q{:};
193Readonly::Scalar our $SCOLON => q{;};
194Readonly::Scalar our $QUOTE => q{'};
195Readonly::Scalar our $DQUOTE => q{"};
196Readonly::Scalar our $BACKTICK => q{`};
197Readonly::Scalar our $PERIOD => q{.};
198Readonly::Scalar our $PIPE => q{|};
199Readonly::Scalar our $SPACE => q{ };
200Readonly::Scalar our $SLASH => q{/};
201Readonly::Scalar our $BSLASH => q{\\};
202Readonly::Scalar our $LEFT_PAREN => q{(};
203Readonly::Scalar our $RIGHT_PAREN => q{)};
204Readonly::Scalar our $EMPTY => q{};
205Readonly::Scalar our $TRUE => 1;
206Readonly::Scalar our $FALSE => 0;
59b05e08 207
6036a254 208#-----------------------------------------------------------------------------
6b4a61e9 209
8d6b89b3
JRT
210#TODO: Should this include punctuations vars?
211
59b05e08 212
8d6b89b3 213
6036a254 214#-----------------------------------------------------------------------------
dc93df4f 215## no critic (ProhibitNoisyQuotes);
57973330 216
c680a9c9 217Readonly::Hash my %PRECEDENCE_OF => (
05b5f925 218 '->' => 1, '<' => 10, '//' => 15, '.=' => 19,
d0dd0a1a
JRT
219 '++' => 2, '>' => 10, '||' => 15, '^=' => 19,
220 '--' => 2, '<=' => 10, '..' => 16, '<<=' => 19,
221 '**' => 3, '>=' => 10, '...' => 17, '>>=' => 19,
222 '!' => 4, 'lt' => 10, '?' => 18, ',' => 20,
223 '~' => 4, 'gt' => 10, ':' => 18, '=>' => 20,
224 '\\' => 4, 'le' => 10, '=' => 19, 'not' => 22,
225 '=~' => 5, 'ge' => 10, '+=' => 19, 'and' => 23,
226 '!~' => 5, '==' => 11, '-=' => 19, 'or' => 24,
227 '*' => 6, '!=' => 11, '*=' => 19, 'xor' => 24,
228 '/' => 6, '<=>' => 11, '/=' => 19,
229 '%' => 6, 'eq' => 11, '%=' => 19,
230 'x' => 6, 'ne' => 11, '||=' => 19,
231 '+' => 7, 'cmp' => 11, '&&=' => 19,
232 '-' => 7, '&' => 12, '|=' => 19,
233 '.' => 7, '|' => 13, '&=' => 19,
234 '<<' => 8, '^' => 13, '**=' => 19,
235 '>>' => 8, '&&' => 14, 'x=' => 19,
8d6b89b3
JRT
236);
237
57973330 238## use critic
7b84ff16 239#-----------------------------------------------------------------------------
8d6b89b3 240
c0631e45 241sub hashify { ## no critic (ArgUnpacking)
3ffdaa3b
AL
242 return map { $_ => 1 } @_;
243}
244
7b84ff16
JRT
245#-----------------------------------------------------------------------------
246
247sub interpolate {
248 my ( $literal ) = @_;
c0631e45 249 return eval "\"$literal\""; ## no critic (StringyEval);
7b84ff16
JRT
250}
251
252#-----------------------------------------------------------------------------
3ffdaa3b 253
59b05e08
JRT
254sub find_keywords {
255 my ( $doc, $keyword ) = @_;
45acb16b
CD
256 my $nodes_ref = $doc->find('PPI::Token::Word');
257 return if !$nodes_ref;
59b05e08
JRT
258 my @matches = grep { $_ eq $keyword } @{$nodes_ref};
259 return @matches ? \@matches : undef;
260}
261
7b84ff16 262#-----------------------------------------------------------------------------
c948abe5
ES
263
264sub _name_for_sub_or_stringified_element {
265 my $elem = shift;
266
267 if ( blessed $elem and $elem->isa('PPI::Statement::Sub') ) {
268 return $elem->name();
269 }
270
271 return "$elem";
272}
273
274#-----------------------------------------------------------------------------
207c8eb0 275## no critic (ProhibitPackageVars)
dff08b70 276
c680a9c9 277Readonly::Hash my %BUILTINS => hashify( @B::Keywords::Functions );
e2d4c0f0 278
8d6b89b3 279sub is_perl_builtin {
45acb16b
CD
280 my $elem = shift;
281 return if !$elem;
c948abe5
ES
282
283 return exists $BUILTINS{ _name_for_sub_or_stringified_element($elem) };
8d6b89b3 284}
36f7994c 285
7b84ff16 286#-----------------------------------------------------------------------------
8d6b89b3 287
c680a9c9 288Readonly::Hash my %BAREWORDS => hashify( @B::Keywords::Barewords );
3ca95ec9
JRT
289
290sub is_perl_bareword {
291 my $elem = shift;
292 return if !$elem;
293
294 return exists $BAREWORDS{ _name_for_sub_or_stringified_element($elem) };
295}
296
297#-----------------------------------------------------------------------------
298
093d3a00
ES
299sub _build_globals_without_sigils {
300 my @globals = map { substr $_, 1 } @B::Keywords::Arrays,
301 @B::Keywords::Hashes,
302 @B::Keywords::Scalars;
303
304 # Not all of these have sigils
305 foreach my $filehandle (@B::Keywords::Filehandles) {
306 (my $stripped = $filehandle) =~ s< \A [*] ><>xms;
307 push @globals, $stripped;
308 }
309
310 return @globals;
311}
312
313Readonly::Array my @GLOBALS_WITHOUT_SIGILS => _build_globals_without_sigils();
e2d4c0f0 314
c680a9c9 315Readonly::Hash my %GLOBALS => hashify( @GLOBALS_WITHOUT_SIGILS );
e2d4c0f0 316
8d6b89b3 317sub is_perl_global {
45acb16b
CD
318 my $elem = shift;
319 return if !$elem;
3c71d40c 320 my $var_name = "$elem"; #Convert Token::Symbol to string
f135623f 321 $var_name =~ s{\A [\$@%*] }{}xms; #Chop off the sigil
3c71d40c 322 return exists $GLOBALS{ $var_name };
8d6b89b3
JRT
323}
324
2c30044d
JRT
325#-----------------------------------------------------------------------------
326
c680a9c9 327Readonly::Hash my %FILEHANDLES => hashify( @B::Keywords::Filehandles );
2c30044d
JRT
328
329sub is_perl_filehandle {
330 my $elem = shift;
331 return if !$elem;
332
333 return exists $FILEHANDLES{ _name_for_sub_or_stringified_element($elem) };
334}
335
207c8eb0 336## use critic
7b84ff16 337#-----------------------------------------------------------------------------
8d6b89b3 338
c948abe5 339# egrep '=item.*LIST' perlfunc.pod
c680a9c9 340Readonly::Hash my %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT =>
c948abe5
ES
341 hashify(
342 qw{
343 chmod
344 chown
345 die
346 exec
347 formline
348 grep
349 import
350 join
351 kill
352 map
353 no
354 open
355 pack
356 print
357 printf
358 push
359 reverse
19d26f4f 360 say
c948abe5
ES
361 sort
362 splice
363 sprintf
364 syscall
365 system
366 tie
367 unlink
368 unshift
369 use
370 utime
371 warn
27ac78c7 372 },
c948abe5
ES
373 );
374
375sub is_perl_builtin_with_list_context {
376 my $elem = shift;
377
378 return
379 exists
380 $BUILTINS_WHICH_PROVIDE_LIST_CONTEXT{
381 _name_for_sub_or_stringified_element($elem)
382 };
383}
384
385#-----------------------------------------------------------------------------
386
387# egrep '=item.*[A-Z],' perlfunc.pod
c680a9c9 388Readonly::Hash my %BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS =>
c948abe5
ES
389 hashify(
390 qw{
391 accept
392 atan2
393 bind
394 binmode
395 bless
396 connect
397 crypt
398 dbmopen
399 fcntl
400 flock
401 gethostbyaddr
402 getnetbyaddr
403 getpriority
404 getservbyname
405 getservbyport
406 getsockopt
407 index
408 ioctl
409 link
410 listen
411 mkdir
412 msgctl
413 msgget
414 msgrcv
415 msgsnd
416 open
417 opendir
418 pipe
419 read
420 recv
421 rename
422 rindex
423 seek
424 seekdir
425 select
426 semctl
427 semget
428 semop
429 send
430 setpgrp
431 setpriority
432 setsockopt
433 shmctl
434 shmget
435 shmread
436 shmwrite
437 shutdown
438 socket
439 socketpair
440 splice
441 split
442 substr
443 symlink
444 sysopen
445 sysread
446 sysseek
447 syswrite
448 truncate
449 unpack
450 vec
451 waitpid
452 },
453 keys %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT
454 );
455
456sub is_perl_builtin_with_multiple_arguments {
457 my $elem = shift;
458
459 return
460 exists
461 $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{
462 _name_for_sub_or_stringified_element($elem)
463 };
464}
465
466#-----------------------------------------------------------------------------
467
c680a9c9 468Readonly::Hash my %BUILTINS_WHICH_TAKE_NO_ARGUMENTS =>
27ac78c7
ES
469 hashify(
470 qw{
471 endgrent
472 endhostent
473 endnetent
474 endprotoent
475 endpwent
476 endservent
477 fork
478 format
479 getgrent
480 gethostent
481 getlogin
482 getnetent
483 getppid
484 getprotoent
485 getpwent
486 getservent
487 setgrent
488 setpwent
489 split
490 time
491 times
492 wait
493 wantarray
494 }
495 );
496
497sub is_perl_builtin_with_no_arguments {
498 my $elem = shift;
499
500 return
501 exists
502 $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{
503 _name_for_sub_or_stringified_element($elem)
504 };
505}
506
507#-----------------------------------------------------------------------------
508
c680a9c9 509Readonly::Hash my %BUILTINS_WHICH_TAKE_ONE_ARGUMENT =>
27ac78c7
ES
510 hashify(
511 qw{
512 closedir
513 dbmclose
514 delete
515 each
516 exists
517 fileno
518 getgrgid
519 getgrnam
520 gethostbyname
521 getnetbyname
522 getpeername
523 getpgrp
524 getprotobyname
525 getprotobynumber
526 getpwnam
527 getpwuid
528 getsockname
529 goto
530 keys
531 local
532 prototype
533 readdir
534 readline
535 readpipe
536 rewinddir
537 scalar
538 sethostent
539 setnetent
540 setprotoent
541 setservent
542 telldir
543 tied
544 untie
545 values
546 }
547 );
548
549sub is_perl_builtin_with_one_argument {
550 my $elem = shift;
551
552 return
553 exists
554 $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{
555 _name_for_sub_or_stringified_element($elem)
556 };
557}
558
559#-----------------------------------------------------------------------------
560
561## no critic (ProhibitPackageVars)
c680a9c9 562Readonly::Hash my %BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT =>
27ac78c7
ES
563 hashify(
564 grep { not exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $_ } }
565 grep { not exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $_ } }
566 grep { not exists $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{ $_ } }
567 @B::Keywords::Functions
568 );
569## use critic
570
571sub is_perl_builtin_with_optional_argument {
572 my $elem = shift;
573
574 return
575 exists
576 $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{
577 _name_for_sub_or_stringified_element($elem)
578 };
579}
580
581#-----------------------------------------------------------------------------
582
583sub is_perl_builtin_with_zero_and_or_one_arguments {
584 my $elem = shift;
8e2aefdb 585
27ac78c7
ES
586 return if not $elem;
587
588 my $name = _name_for_sub_or_stringified_element($elem);
589
590 return (
591 exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $name }
592 or exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $name }
593 or exists $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{ $name }
594 );
595}
596
597#-----------------------------------------------------------------------------
598
ee3a2f51
ES
599sub is_qualified_name {
600 my $name = shift;
601
602 return if not $name;
603
604 return index ( $name, q{::} ) >= 0;
605}
606
607#-----------------------------------------------------------------------------
608
8d6b89b3 609sub precedence_of {
45acb16b
CD
610 my $elem = shift;
611 return if !$elem;
3c71d40c 612 return $PRECEDENCE_OF{ ref $elem ? "$elem" : $elem };
8d6b89b3
JRT
613}
614
7b84ff16 615#-----------------------------------------------------------------------------
8d6b89b3 616
59b05e08
JRT
617sub is_hash_key {
618 my $elem = shift;
45acb16b 619 return if !$elem;
59b05e08 620
47a710b9
JRT
621 #If followed by an argument list, then its a function call, not a literal
622 return if _is_followed_by_parens($elem);
623
59b05e08 624 #Check curly-brace style: $hash{foo} = bar;
45acb16b
CD
625 my $parent = $elem->parent();
626 return if !$parent;
627 my $grandparent = $parent->parent();
628 return if !$grandparent;
59b05e08
JRT
629 return 1 if $grandparent->isa('PPI::Structure::Subscript');
630
631
632 #Check declarative style: %hash = (foo => bar);
45acb16b
CD
633 my $sib = $elem->snext_sibling();
634 return if !$sib;
59b05e08
JRT
635 return 1 if $sib->isa('PPI::Token::Operator') && $sib eq '=>';
636
45acb16b 637 return;
59b05e08
JRT
638}
639
7b84ff16 640#-----------------------------------------------------------------------------
dff08b70 641
47a710b9
JRT
642sub _is_followed_by_parens {
643 my $elem = shift;
644 return if !$elem;
645
646 my $sibling = $elem->snext_sibling() || return;
647 return $sibling->isa('PPI::Structure::List');
648}
649
650#-----------------------------------------------------------------------------
651
0893757b
ES
652sub is_included_module_name {
653 my $elem = shift;
654 return if !$elem;
655 my $stmnt = $elem->statement();
656 return if !$stmnt;
657 return if !$stmnt->isa('PPI::Statement::Include');
658 return $stmnt->schild(1) == $elem;
659}
660
661#-----------------------------------------------------------------------------
662
2e0f1c94 663sub is_integer {
6e7d6c9f
CD
664 my ($value) = @_;
665 return 0 if not defined $value;
2e0f1c94 666
f135623f 667 return $value =~ m{ \A [+-]? \d+ \z }xms;
2e0f1c94
ES
668}
669
670#-----------------------------------------------------------------------------
671
aa0d7c6e
JRT
672sub is_label_pointer {
673 my $elem = shift;
674 return if !$elem;
675
676 my $statement = $elem->statement();
677 return if !$statement;
678
679 my $psib = $elem->sprevious_sibling();
680 return if !$psib;
681
682 return $statement->isa('PPI::Statement::Break')
f135623f 683 && $psib =~ m/(?:redo|goto|next|last)/xmso;
aa0d7c6e
JRT
684}
685
686#-----------------------------------------------------------------------------
687
59b05e08
JRT
688sub is_method_call {
689 my $elem = shift;
45acb16b 690 return if !$elem;
8053d374 691
f7a00b57
JRT
692 return _is_dereference_operator( $elem->sprevious_sibling() );
693}
694
695#-----------------------------------------------------------------------------
696
697sub is_class_name {
698 my $elem = shift;
699 return if !$elem;
700
334c45ee
JRT
701 return _is_dereference_operator( $elem->snext_sibling() )
702 && !_is_dereference_operator( $elem->sprevious_sibling() );
8053d374
JRT
703}
704
705#-----------------------------------------------------------------------------
706
707sub _is_dereference_operator {
708 my $elem = shift;
709 return if !$elem;
710
711 return $elem->isa('PPI::Token::Operator') && $elem eq q{->};
59b05e08
JRT
712}
713
7b84ff16 714#-----------------------------------------------------------------------------
dff08b70 715
bdaf4dac
ES
716sub is_package_declaration {
717 my $elem = shift;
718 return if !$elem;
719 my $stmnt = $elem->statement();
720 return if !$stmnt;
721 return if !$stmnt->isa('PPI::Statement::Package');
722 return $stmnt->schild(1) == $elem;
723}
724
725#-----------------------------------------------------------------------------
726
0c377685
JRT
727sub is_subroutine_name {
728 my $elem = shift;
45acb16b
CD
729 return if !$elem;
730 my $sib = $elem->sprevious_sibling();
731 return if !$sib;
732 my $stmnt = $elem->statement();
733 return if !$stmnt;
0c377685
JRT
734 return $stmnt->isa('PPI::Statement::Sub') && $sib eq 'sub';
735}
736
7b84ff16 737#-----------------------------------------------------------------------------
0c377685 738
dc118d1b
JRT
739sub is_function_call {
740 my $elem = shift;
47a710b9 741 return if !$elem;
3ca95ec9
JRT
742
743 return if is_hash_key($elem);
744 return if is_method_call($elem);
f7a00b57 745 return if is_class_name($elem);
3ca95ec9
JRT
746 return if is_subroutine_name($elem);
747 return if is_included_module_name($elem);
748 return if is_package_declaration($elem);
749 return if is_perl_bareword($elem);
2c30044d 750 return if is_perl_filehandle($elem);
aa0d7c6e 751 return if is_label_pointer($elem);
3ca95ec9
JRT
752
753 return 1;
dc118d1b
JRT
754}
755
7b84ff16 756#-----------------------------------------------------------------------------
dc118d1b 757
dff08b70
JRT
758sub is_script {
759 my $doc = shift;
e992086d 760
deb58212
JRT
761 return 1 if shebang_line($doc);
762 return 1 if _is_PL_file($doc);
763 return 0;
764}
765
766#-----------------------------------------------------------------------------
767
768sub _is_PL_file {
769 my ($doc) = @_;
770 return if not $doc->can('filename');
771 my $filename = $doc->filename() || return;
f135623f 772 return 1 if $filename =~ m/[.] PL \z/xms;
deb58212 773 return 0;
dff08b70
JRT
774}
775
7b84ff16 776#-----------------------------------------------------------------------------
dff08b70 777
464d4c66
ES
778sub is_in_void_context {
779 my ($token) = @_;
780
781 # If part of a collective, can't be void.
782 return if $token->sprevious_sibling();
783
784 my $parent = $token->statement()->parent();
785 if ($parent) {
786 return if $parent->isa('PPI::Structure::List');
787 return if $parent->isa('PPI::Structure::ForLoop');
788 return if $parent->isa('PPI::Structure::Condition');
789 return if $parent->isa('PPI::Structure::Constructor');
790
791 my $grand_parent = $parent->parent();
792 if ($grand_parent) {
793 return if
794 $parent->isa('PPI::Structure::Block')
795 and not $grand_parent->isa('PPI::Statement::Compound');
796 }
797 }
798
799 return $TRUE;
800}
801
802#-----------------------------------------------------------------------------
803
dc93df4f 804sub policy_long_name {
1fe8e187 805 my ( $policy_name ) = @_;
f135623f 806 if ( $policy_name !~ m{ \A $POLICY_NAMESPACE }xms ) {
1fe8e187 807 $policy_name = $POLICY_NAMESPACE . q{::} . $policy_name;
dc93df4f
JRT
808 }
809 return $policy_name;
810}
811
7b84ff16 812#-----------------------------------------------------------------------------
dc93df4f
JRT
813
814sub policy_short_name {
1fe8e187 815 my ( $policy_name ) = @_;
f135623f 816 $policy_name =~ s{\A $POLICY_NAMESPACE ::}{}xms;
dc93df4f
JRT
817 return $policy_name;
818}
819
7b84ff16 820#-----------------------------------------------------------------------------
dc93df4f 821
14a6a3ef
CD
822sub first_arg {
823 my $elem = shift;
824 my $sib = $elem->snext_sibling();
825 return if !$sib;
826
827 if ( $sib->isa('PPI::Structure::List') ) {
828
829 my $expr = $sib->schild(0);
830 return if !$expr;
831 return $expr->isa('PPI::Statement') ? $expr->schild(0) : $expr;
832 }
833
834 return $sib;
835}
836
837#-----------------------------------------------------------------------------
838
59b05e08
JRT
839sub parse_arg_list {
840 my $elem = shift;
45acb16b
CD
841 my $sib = $elem->snext_sibling();
842 return if !$sib;
59b05e08
JRT
843
844 if ( $sib->isa('PPI::Structure::List') ) {
845
0a6f07d0 846 #Pull siblings from list
329eea9a
ES
847 my @list_contents = $sib->schildren();
848 return if not @list_contents;
849
850 my @list_expressions;
851 foreach my $item (@list_contents) {
852 if (
853 is_ppi_expression_or_generic_statement($item)
854 ) {
855 push
856 @list_expressions,
857 split_nodes_on_comma( $item->schildren() );
858 }
859 else {
860 push @list_expressions, $item;
861 }
862 }
863
864 return @list_expressions;
59b05e08
JRT
865 }
866 else {
867
0a6f07d0
AL
868 #Gather up remaining nodes in the statement
869 my $iter = $elem;
870 my @arg_list = ();
59b05e08 871
0a6f07d0
AL
872 while ($iter = $iter->snext_sibling() ) {
873 last if $iter->isa('PPI::Token::Structure') and $iter eq $SCOLON;
874 push @arg_list, $iter;
875 }
2b6293b2 876 return split_nodes_on_comma( @arg_list );
59b05e08
JRT
877 }
878}
879
dff08b70
JRT
880#---------------------------------
881
c6e19b74 882sub split_nodes_on_comma {
6e7d6c9f
CD
883 my @nodes = @_;
884
59b05e08 885 my $i = 0;
6e7d6c9f
CD
886 my @node_stacks;
887 for my $node (@nodes) {
329eea9a
ES
888 if (
889 $node->isa('PPI::Token::Operator')
890 and ($node eq $COMMA or $node eq $FATCOMMA)
891 ) {
892 if (@node_stacks) {
893 $i++; #Move forward to next 'node stack'
894 }
0a6f07d0 895 next;
2b6293b2
CD
896 } elsif ( $node->isa('PPI::Token::QuoteLike::Words' )) {
897 my $section = $node->{sections}->[0];
898 my @words = words_from_string(substr $node->content, $section->{position}, $section->{size});
899 my $loc = $node->location;
900 for my $word (@words) {
901 my $token = PPI::Token::Quote::Single->new(q{'} . $word . q{'});
902 $token->{_location} = $loc;
903 push @{ $node_stacks[$i++] }, $token;
904 }
905 next;
0a6f07d0 906 }
6e7d6c9f 907 push @{ $node_stacks[$i] }, $node;
59b05e08 908 }
6e7d6c9f 909 return @node_stacks;
59b05e08 910}
bf159007 911
8645eb2c
JRT
912#-----------------------------------------------------------------------------
913
23952868
JJ
914# XXX: You must keep the regular expressions in extras/perlcritic.el in sync
915# if you change these.
c680a9c9 916Readonly::Hash my %FORMAT_OF => (
4268e673
JRT
917 1 => "%f:%l:%c:%m\n",
918 2 => "%f: (%l:%c) %m\n",
b57cebc1
JRT
919 3 => "%m at %f line %l\n",
920 4 => "%m at line %l, column %c. %e. (Severity: %s)\n",
921 5 => "%f: %m at line %l, column %c. %e. (Severity: %s)\n",
922 6 => "%m at line %l, near '%r'. (Severity: %s)\n",
923 7 => "%f: %m at line %l near '%r'. (Severity: %s)\n",
924 8 => "[%p] %m at line %l, column %c. (Severity: %s)\n",
925 9 => "[%p] %m at line %l, near '%r'. (Severity: %s)\n",
926 10 => "%m at line %l, column %c.\n %p (Severity: %s)\n%d\n",
927 11 => "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n",
4268e673
JRT
928);
929
c680a9c9
ES
930Readonly::Scalar our $DEFAULT_VERBOSITY => 4;
931Readonly::Scalar our $DEFAULT_VERBOSITY_WITH_FILE_NAME => 5;
932Readonly::Scalar my $DEFAULT_FORMAT => $FORMAT_OF{$DEFAULT_VERBOSITY};
9f6df1c1 933
2e0f1c94
ES
934sub is_valid_numeric_verbosity {
935 my ($verbosity) = @_;
936
937 return exists $FORMAT_OF{$verbosity};
938}
939
4268e673 940sub verbosity_to_format {
9f6df1c1
JRT
941 my ($verbosity) = @_;
942 return $DEFAULT_FORMAT if not defined $verbosity;
2e0f1c94 943 return $FORMAT_OF{abs int $verbosity} || $DEFAULT_FORMAT if is_integer($verbosity);
9f6df1c1 944 return interpolate( $verbosity ); #Otherwise, treat as a format spec
4268e673
JRT
945}
946
947#-----------------------------------------------------------------------------
948
c680a9c9 949Readonly::Hash my %SEVERITY_NUMBER_OF => (
0bcb38c0
JRT
950 gentle => 5,
951 stern => 4,
952 harsh => 3,
953 cruel => 2,
954 brutal => 1,
955);
956
c680a9c9
ES
957Readonly::Array our @SEVERITY_NAMES => #This is exported!
958 sort
959 { $SEVERITY_NUMBER_OF{$a} <=> $SEVERITY_NUMBER_OF{$b} }
960 keys %SEVERITY_NUMBER_OF;
0bcb38c0
JRT
961
962sub severity_to_number {
963 my ($severity) = @_;
2e0f1c94 964 return _normalize_severity( $severity ) if is_integer( $severity );
0bcb38c0 965 my $severity_number = $SEVERITY_NUMBER_OF{lc $severity};
4b1bd955
ES
966
967 if ( not defined $severity_number ) {
968 throw_generic qq{Invalid severity: "$severity"};
969 }
970
0bcb38c0
JRT
971 return $severity_number;
972}
973
974sub _normalize_severity {
975 my $s = shift || return $SEVERITY_HIGHEST;
976 $s = $s > $SEVERITY_HIGHEST ? $SEVERITY_HIGHEST : $s;
977 $s = $s < $SEVERITY_LOWEST ? $SEVERITY_LOWEST : $s;
978 return $s;
979}
980
981#-----------------------------------------------------------------------------
982
c680a9c9
ES
983Readonly::Array my @skip_dir => qw( CVS RCS .svn _darcs {arch} .bzr _build blib );
984Readonly::Hash my %skip_dir => hashify( @skip_dir );
a91b8a46 985
8645eb2c
JRT
986sub all_perl_files {
987
988 # Recursively searches a list of directories and returns the paths
989 # to files that seem to be Perl source code. This subroutine was
990 # poached from Test::Perl::Critic.
991
8645eb2c
JRT
992 my @queue = @_;
993 my @code_files = ();
994
995 while (@queue) {
996 my $file = shift @queue;
997 if ( -d $file ) {
998 opendir my ($dh), $file or next;
999 my @newfiles = sort readdir $dh;
1000 closedir $dh;
1001
1002 @newfiles = File::Spec->no_upwards(@newfiles);
1003 @newfiles = grep { !$skip_dir{$_} } @newfiles;
1004 push @queue, map { File::Spec->catfile($file, $_) } @newfiles;
1005 }
1006
1007 if ( (-f $file) && ! _is_backup($file) && _is_perl($file) ) {
1008 push @code_files, $file;
1009 }
1010 }
1011 return @code_files;
1012}
1013
1014
1015#-----------------------------------------------------------------------------
1016# Decide if it's some sort of backup file
1017
1018sub _is_backup {
1019 my ($file) = @_;
f135623f
ES
1020 return 1 if $file =~ m{ [.] swp \z}xms;
1021 return 1 if $file =~ m{ [.] bak \z}xms;
1022 return 1 if $file =~ m{ ~ \z}xms;
1023 return 1 if $file =~ m{ \A [#] .+ [#] \z}xms;
8645eb2c
JRT
1024 return;
1025}
1026
1027#-----------------------------------------------------------------------------
1028# Returns true if the argument ends with a perl-ish file
1029# extension, or if it has a shebang-line containing 'perl' This
1030# subroutine was also poached from Test::Perl::Critic
1031
1032sub _is_perl {
1033 my ($file) = @_;
1034
1035 #Check filename extensions
f135623f
ES
1036 return 1 if $file =~ m{ [.] PL \z}xms;
1037 return 1 if $file =~ m{ [.] p[lm] \z}xms;
1038 return 1 if $file =~ m{ [.] t \z}xms;
8645eb2c
JRT
1039
1040 #Check for shebang
2889349f 1041 open my $fh, '<', $file or return;
8645eb2c 1042 my $first = <$fh>;
4b1bd955 1043 close $fh or throw_generic "unable to close $file: $!";
8645eb2c 1044
f135623f 1045 return 1 if defined $first && ( $first =~ m{ \A [#]!.*perl }xms );
8645eb2c
JRT
1046 return;
1047}
1048
6036a254 1049#-----------------------------------------------------------------------------
bf159007 1050
e2e7b907
CD
1051sub shebang_line {
1052 my $doc = shift;
b9b8ed18
ES
1053 my $first_element = $doc->first_element();
1054 return if not $first_element;
1055 return if not $first_element->isa('PPI::Token::Comment');
1056 my $location = $first_element->location();
e2e7b907
CD
1057 return if !$location;
1058 # The shebang must be the first two characters in the file, according to
1059 # http://en.wikipedia.org/wiki/Shebang_(Unix)
1060 return if $location->[0] != 1; # line number
1061 return if $location->[1] != 1; # column number
b9b8ed18 1062 my $shebang = $first_element->content;
f135623f 1063 return if $shebang !~ m{ \A [#]! }xms;
e2e7b907
CD
1064 return $shebang;
1065}
1066
6036a254 1067#-----------------------------------------------------------------------------
e2e7b907 1068
4a7a7227
AL
1069sub words_from_string {
1070 my $str = shift;
1071
38e3d924 1072 return split q{ }, $str; # This must be a literal space, not $SPACE
4a7a7227
AL
1073}
1074
9fb2d1dc
AM
1075#-----------------------------------------------------------------------------
1076
1077sub is_unchecked_call {
1078 my $elem = shift;
1079
1080 return if not is_function_call( $elem );
1081
1082 # check to see if there's an '=' or 'unless' or something before this.
1083 if( my $sib = $elem->sprevious_sibling() ){
1084 return if $sib;
1085 }
1086
1087
1088 if( my $statement = $elem->statement() ){
1089
1090 # "open or die" is OK.
1091 # We can't check snext_sibling for 'or' since the next siblings are an
1092 # unknown number of arguments to the system call. Instead, check all of
40647aca
JRT
1093 # the elements to this statement to see if we find 'or' or '||'.
1094
1095 my $or_operators = sub {
1096 my (undef, $elem) = @_;
1097 return if not $elem->isa('PPI::Token::Operator');
0f1f4df7 1098 return if $elem ne q{or} && $elem ne q{||};
40647aca
JRT
1099 return 1;
1100 };
1101
1102 return if $statement->find( $or_operators );
1103
9fb2d1dc
AM
1104
1105 if( my $parent = $elem->statement()->parent() ){
1106
40647aca 1107 # Check if we're in an if( open ) {good} else {bad} condition
9fb2d1dc
AM
1108 return if $parent->isa('PPI::Structure::Condition');
1109
40647aca 1110 # Return val could be captured in data structure and checked later
9fb2d1dc
AM
1111 return if $parent->isa('PPI::Structure::Constructor');
1112
1113 # "die if not ( open() )" - It's in list context.
1114 if ( $parent->isa('PPI::Structure::List') ) {
1115 if( my $uncle = $parent->sprevious_sibling() ){
1116 return if $uncle;
1117 }
1118 }
1119 }
1120 }
1121
2b6293b2
CD
1122 return if _is_fatal($elem);
1123
9fb2d1dc
AM
1124 # Otherwise, return. this system call is unchecked.
1125 return 1;
1126}
1127
84ed32d9 1128# Based upon autodie 1.994.
6386d95c
ES
1129Readonly::Hash my %AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP => (
1130 # Map builtins to themselves.
84ed32d9
ES
1131 (
1132 map { $_ => { hashify( $_ ) } }
1133 qw<
1134 accept bind binmode chdir close closedir connect dbmclose
1135 dbmopen exec fcntl fileno flock fork getsockopt ioctl link
1136 listen mkdir msgctl msgget msgrcv msgsnd open opendir pipe
1137 read readlink recv rename rmdir seek semctl semget semop send
1138 setsockopt shmctl shmget shmread shutdown socketpair symlink
1139 sysopen sysread sysseek system syswrite truncate umask unlink
1140 >
1141 ),
1142
1143 # Generate these using tools/dump-autodie-tag-contents
1144 ':threads' => { hashify( qw< fork > ) },
1145 ':system' => { hashify( qw< exec system > ) },
1146 ':dbm' => { hashify( qw< dbmclose dbmopen > ) },
1147 ':semaphore' => { hashify( qw< semctl semget semop > ) },
1148 ':shm' => { hashify( qw< shmctl shmget shmread > ) },
1149 ':msg' => { hashify( qw< msgctl msgget msgrcv msgsnd > ) },
1150 ':file' => {
1151 hashify(
1152 qw<
1153 binmode close fcntl fileno flock ioctl open sysopen truncate
1154 >
1155 )
1156 },
1157 ':filesys' => {
6386d95c
ES
1158 hashify(
1159 qw<
84ed32d9
ES
1160 chdir closedir link mkdir opendir readlink rename rmdir
1161 symlink umask unlink
6386d95c
ES
1162 >
1163 )
1164 },
84ed32d9 1165 ':ipc' => {
6386d95c
ES
1166 hashify(
1167 qw<
84ed32d9
ES
1168 msgctl msgget msgrcv msgsnd pipe semctl semget semop shmctl
1169 shmget shmread
6386d95c
ES
1170 >
1171 )
1172 },
84ed32d9 1173 ':socket' => {
6386d95c
ES
1174 hashify(
1175 qw<
1176 accept bind connect getsockopt listen recv send setsockopt
1177 shutdown socketpair
1178 >
1179 )
1180 },
84ed32d9 1181 ':io' => {
6386d95c
ES
1182 hashify(
1183 qw<
84ed32d9
ES
1184 accept bind binmode chdir close closedir connect dbmclose
1185 dbmopen fcntl fileno flock getsockopt ioctl link listen mkdir
1186 msgctl msgget msgrcv msgsnd open opendir pipe read readlink
1187 recv rename rmdir seek semctl semget semop send setsockopt
1188 shmctl shmget shmread shutdown socketpair symlink sysopen
1189 sysread sysseek syswrite truncate umask unlink
6386d95c
ES
1190 >
1191 )
1192 },
84ed32d9 1193 ':default' => {
6386d95c
ES
1194 hashify(
1195 qw<
84ed32d9
ES
1196 accept bind binmode chdir close closedir connect dbmclose
1197 dbmopen fcntl fileno flock fork getsockopt ioctl link listen
1198 mkdir msgctl msgget msgrcv msgsnd open opendir pipe read
1199 readlink recv rename rmdir seek semctl semget semop send
1200 setsockopt shmctl shmget shmread shutdown socketpair symlink
1201 sysopen sysread sysseek syswrite truncate umask unlink
6386d95c
ES
1202 >
1203 )
1204 },
84ed32d9 1205 ':all' => {
6386d95c
ES
1206 hashify(
1207 qw<
84ed32d9
ES
1208 accept bind binmode chdir close closedir connect dbmclose
1209 dbmopen exec fcntl fileno flock fork getsockopt ioctl link
1210 listen mkdir msgctl msgget msgrcv msgsnd open opendir pipe
1211 read readlink recv rename rmdir seek semctl semget semop send
1212 setsockopt shmctl shmget shmread shutdown socketpair symlink
1213 sysopen sysread sysseek system syswrite truncate umask unlink
6386d95c
ES
1214 >
1215 )
1216 },
1217);
1218
2b6293b2
CD
1219sub _is_fatal {
1220 my ($elem) = @_;
1221
6386d95c
ES
1222 my $top = $elem->top();
1223 return if not $top->isa('PPI::Document');
1224
2b6293b2 1225 my $includes = $top->find('PPI::Statement::Include');
6386d95c
ES
1226 return if not $includes;
1227
2b6293b2 1228 for my $include (@{$includes}) {
6386d95c
ES
1229 next if 'use' ne $include->type();
1230
1231 if ('Fatal' eq $include->module()) {
2b6293b2 1232 my @args = parse_arg_list($include->schild(1));
6386d95c
ES
1233 foreach my $arg (@args) {
1234 return $TRUE if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string();
2b6293b2 1235 }
6386d95c
ES
1236 }
1237 elsif ('Fatal::Exception' eq $include->module()) {
2b6293b2
CD
1238 my @args = parse_arg_list($include->schild(1));
1239 shift @args; # skip exception class name
6386d95c
ES
1240 foreach my $arg (@args) {
1241 return $TRUE if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string();
1242 }
1243 }
1244 elsif ('autodie' eq $include->pragma()) {
84ed32d9
ES
1245 return _is_covered_by_autodie($elem, $include);
1246 }
1247 }
6386d95c 1248
84ed32d9
ES
1249 return;
1250}
6386d95c 1251
84ed32d9
ES
1252sub _is_covered_by_autodie {
1253 my ($elem, $include) = @_;
6386d95c 1254
84ed32d9
ES
1255 my @args = parse_arg_list($include->schild(1));
1256
1257 if (@args) {
1258 foreach my $arg (@args) {
1259 my $builtins =
1260 $AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP{
1261 $arg->[0]->string
1262 };
1263
1264 return $TRUE if $builtins and $builtins->{$elem->content()};
2b6293b2
CD
1265 }
1266 }
84ed32d9
ES
1267 else {
1268 my $builtins =
1269 $AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP{':default'};
1270
1271 return $TRUE if $builtins and $builtins->{$elem->content()};
1272 }
6386d95c 1273
2b6293b2
CD
1274 return;
1275}
4a7a7227 1276
59b05e08
JRT
12771;
1278
1279__END__
1280
dff08b70
JRT
1281=pod
1282
59b05e08
JRT
1283=head1 NAME
1284
c728943a 1285Perl::Critic::Utils - General utility subroutines and constants for Perl::Critic and derivative distributions.
59b05e08 1286
11f53956 1287
59b05e08
JRT
1288=head1 DESCRIPTION
1289
11f53956
ES
1290This module provides several static subs and variables that are useful
1291for developing L<Perl::Critic::Policy|Perl::Critic::Policy>
1292subclasses. Unless you are writing Policy modules, you probably don't
1293care about this package.
1294
59b05e08 1295
bbf4108c 1296=head1 IMPORTABLE SUBS
59b05e08
JRT
1297
1298=over 8
1299
6d9feae6 1300=item C<find_keywords( $doc, $keyword )>
59b05e08 1301
11f53956
ES
1302B<DEPRECATED:> Since version 0.11, every Policy is evaluated at each
1303element of the document. So you shouldn't need to go looking for a
1304particular keyword. If you I<do> want to use this, please import it
1305via the C<:deprecated> tag, rather than directly, to mark the module
1306as needing updating.
1307
1308Given a L<PPI::Document|PPI::Document> as C<$doc>, returns a reference
1309to an array containing all the L<PPI::Token::Word|PPI::Token::Word>
1310elements that match C<$keyword>. This can be used to find any
1311built-in function, method call, bareword, or reserved keyword. It
1312will not match variables, subroutine names, literal strings, numbers,
1313or symbols. If the document doesn't contain any matches, returns
bbf4108c 1314undef.
59b05e08 1315
11f53956 1316
8d6b89b3
JRT
1317=item C<is_perl_global( $element )>
1318
11f53956
ES
1319Given a L<PPI::Token::Symbol|PPI::Token::Symbol> or a string, returns
1320true if that token represents one of the global variables provided by
1321the L<English|English> module, or one of the builtin global variables
1322like C<%SIG>, C<%ENV>, or C<@ARGV>. The sigil on the symbol is
1323ignored, so things like C<$ARGV> or C<$ENV> will still return true.
1324
8d6b89b3
JRT
1325
1326=item C<is_perl_builtin( $element )>
1327
11f53956
ES
1328Given a L<PPI::Token::Word|PPI::Token::Word>,
1329L<PPI::Statement::Sub|PPI::Statement::Sub>, or string, returns true if
1330that token represents a call to any of the builtin functions defined
1331in Perl 5.8.8.
1332
c948abe5 1333
3ca95ec9
JRT
1334=item C<is_perl_bareword( $element )>
1335
11f53956
ES
1336Given a L<PPI::Token::Word|PPI::Token::Word>,
1337L<PPI::Statement::Sub|PPI::Statement::Sub>, or string, returns true if
1338that token represents a bareword (e.g. "if", "else", "sub", "package")
3ca95ec9
JRT
1339defined in Perl 5.8.8.
1340
11f53956 1341
2c30044d
JRT
1342=item C<is_perl_filehandle( $element )>
1343
11f53956
ES
1344Given a L<PPI::Token::Word|PPI::Token::Word>, or string, returns true
1345if that token represents one of the global filehandles (e.g. C<STDIN>,
1346C<STDERR>, C<STDOUT>, C<ARGV>) that are defined in Perl 5.8.8. Note
1347that this function will return false if given a filehandle that is
1348represented as a typeglob (e.g. C<*STDIN>)
1349
2c30044d 1350
c948abe5
ES
1351=item C<is_perl_builtin_with_list_context( $element )>
1352
11f53956
ES
1353Given a L<PPI::Token::Word|PPI::Token::Word>,
1354L<PPI::Statement::Sub|PPI::Statement::Sub>, or string, returns true if
1355that token represents a call to any of the builtin functions defined
1356in Perl 5.8.8 that provide a list context to the following tokens.
1357
c948abe5
ES
1358
1359=item C<is_perl_builtin_with_multiple_arguments( $element )>
1360
11f53956
ES
1361Given a L<PPI::Token::Word|PPI::Token::Word>,
1362L<PPI::Statement::Sub|PPI::Statement::Sub>, or string, returns true if
1363that token represents a call to any of the builtin functions defined
1364in Perl 5.8.8 that B<can> take multiple arguments.
1365
27ac78c7
ES
1366
1367=item C<is_perl_builtin_with_no_arguments( $element )>
1368
11f53956
ES
1369Given a L<PPI::Token::Word|PPI::Token::Word>,
1370L<PPI::Statement::Sub|PPI::Statement::Sub>, or string, returns true if
1371that token represents a call to any of the builtin functions defined
1372in Perl 5.8.8 that B<cannot> take any arguments.
1373
27ac78c7
ES
1374
1375=item C<is_perl_builtin_with_one_argument( $element )>
1376
11f53956
ES
1377Given a L<PPI::Token::Word|PPI::Token::Word>,
1378L<PPI::Statement::Sub|PPI::Statement::Sub>, or string, returns true if
1379that token represents a call to any of the builtin functions defined
1380in Perl 5.8.8 that takes B<one and only one> argument.
1381
27ac78c7
ES
1382
1383=item C<is_perl_builtin_with_optional_argument( $element )>
1384
11f53956
ES
1385Given a L<PPI::Token::Word|PPI::Token::Word>,
1386L<PPI::Statement::Sub|PPI::Statement::Sub>, or string, returns true if
1387that token represents a call to any of the builtin functions defined
1388in Perl 5.8.8 that takes B<no more than one> argument.
27ac78c7 1389
11f53956
ES
1390The sets of values for which
1391C<is_perl_builtin_with_multiple_arguments()>,
27ac78c7
ES
1392C<is_perl_builtin_with_no_arguments()>,
1393C<is_perl_builtin_with_one_argument()>, and
11f53956
ES
1394C<is_perl_builtin_with_optional_argument()> return true are disjoint
1395and their union is precisely the set of values that
1396C<is_perl_builtin()> will return true for.
1397
27ac78c7
ES
1398
1399=item C<is_perl_builtin_with_zero_and_or_one_arguments( $element )>
1400
11f53956
ES
1401Given a L<PPI::Token::Word|PPI::Token::Word>,
1402L<PPI::Statement::Sub|PPI::Statement::Sub>, or string, returns true if
1403that token represents a call to any of the builtin functions defined
1404in Perl 5.8.8 that takes no and/or one argument.
27ac78c7
ES
1405
1406Returns true if any of C<is_perl_builtin_with_no_arguments()>,
1407C<is_perl_builtin_with_one_argument()>, and
1408C<is_perl_builtin_with_optional_argument()> returns true.
8d6b89b3 1409
11f53956 1410
ee3a2f51
ES
1411=item C<is_qualified_name( $name )>
1412
11f53956
ES
1413Given a string, L<PPI::Token::Word|PPI::Token::Word>, or
1414L<PPI::Token::Symbol|PPI::Token::Symbol>, answers whether it has a
1415module component, i.e. contains "::".
1416
ee3a2f51 1417
8d6b89b3
JRT
1418=item C<precedence_of( $element )>
1419
11f53956
ES
1420Given a L<PPI::Token::Operator|PPI::Token::Operator> or a string,
1421returns the precedence of the operator, where 1 is the highest
1422precedence. Returns undef if the precedence can't be determined
1423(which is usually because it is not an operator).
1424
8d6b89b3 1425
6d9feae6 1426=item C<is_hash_key( $element )>
59b05e08 1427
11f53956
ES
1428Given a L<PPI::Element|PPI::Element>, returns true if the element is a
1429literal hash key. PPI doesn't distinguish between regular barewords
1430(like keywords or subroutine calls) and barewords in hash subscripts
1431(which are considered literal). So this subroutine is useful if your
1432Policy is searching for L<PPI::Token::Word|PPI::Token::Word> elements
1433and you want to filter out the hash subscript variety. In both of the
1434following examples, "foo" is considered a hash key:
1435
1436 $hash1{foo} = 1;
1437 %hash2 = (foo => 1);
59b05e08 1438
11f53956
ES
1439But if the bareword is followed by an argument list, then perl treats
1440it as a function call. So in these examples, "foo" is B<not>
1441considered a hash key:
59b05e08 1442
11f53956
ES
1443 $hash1{ foo() } = 1;
1444 &hash2 = (foo() => 1);
47a710b9 1445
47a710b9 1446
bdaf4dac
ES
1447=item C<is_included_module_name( $element )>
1448
11f53956
ES
1449Given a L<PPI::Token::Word|PPI::Token::Word>, returns true if the
1450element is the name of a module that is being included via C<use>,
1451C<require>, or C<no>.
1452
bdaf4dac 1453
2e0f1c94
ES
1454=item C<is_integer( $value )>
1455
11f53956
ES
1456Answers whether the parameter, as a string, looks like an integral
1457value.
1458
2e0f1c94 1459
f7a00b57
JRT
1460=item C<is_class_name( $element )>
1461
11f53956
ES
1462Given a L<PPI::Token::Word|PPI::Token::Word>, returns true if the
1463element that immediately follows this element is the dereference
1464operator "->". When a bareword has a "->" on the B<right> side, it
1465usually means that it is the name of the class (from which a method is
1466being called).
1467
f7a00b57 1468
aa0d7c6e
JRT
1469=item C<is_label_pointer( $element )>
1470
11f53956
ES
1471Given a L<PPI::Token::Word|PPI::Token::Word>, returns true if the
1472element is the label in a C<next>, C<last>, C<redo>, or C<goto>
1473statement. Note this is not the same thing as the label declaration.
1474
aa0d7c6e 1475
6d9feae6 1476=item C<is_method_call( $element )>
59b05e08 1477
11f53956
ES
1478Given a L<PPI::Token::Word|PPI::Token::Word>, returns true if the
1479element that immediately precedes this element is the dereference
1480operator "->". When a bareword has a "->" on the B<left> side, it
1481usually means that it is the name of a method (that is being called
1482from a class).
1483
59b05e08 1484
bdaf4dac 1485=item C<is_package_declaration( $element )>
0c377685 1486
11f53956
ES
1487Given a L<PPI::Token::Word|PPI::Token::Word>, returns true if the
1488element is the name of a package that is being declared.
1489
0c377685 1490
bdaf4dac 1491=item C<is_subroutine_name( $element )>
0893757b 1492
11f53956
ES
1493Given a L<PPI::Token::Word|PPI::Token::Word>, returns true if the
1494element is the name of a subroutine declaration. This is useful for
1495distinguishing barewords and from function calls from subroutine
1496declarations.
1497
0893757b 1498
dc118d1b
JRT
1499=item C<is_function_call( $element )>
1500
11f53956
ES
1501Given a L<PPI::Token::Word|PPI::Token::Word> returns true if the
1502element appears to be call to a static function. Specifically, this
1503function returns true if C<is_hash_key>, C<is_method_call>,
1504C<is_subroutine_name>, C<is_included_module_anme>,
1505C<is_package_declaration>, C<is_perl_bareword>, C<is_perl_filehandle>,
1506C<is_label_pointer> and C<is_subroutine_name> all return false for the
1507given element.
1508
dc118d1b 1509
14a6a3ef
CD
1510=item C<first_arg( $element )>
1511
11f53956
ES
1512Given a L<PPI::Element|PPI::Element> that is presumed to be a function
1513call (which is usually a L<PPI::Token::Word|PPI::Token::Word>), return
1514the first argument. This is similar of C<parse_arg_list()> and
1515follows the same logic. Note that for the code:
1516
1517 int($x + 0.5)
14a6a3ef 1518
11f53956
ES
1519this function will return just the C<$x>, not the whole expression.
1520This is different from the behavior of C<parse_arg_list()>. Another
1521caveat is:
14a6a3ef 1522
11f53956 1523 int(($x + $y) + 0.5)
14a6a3ef 1524
11f53956
ES
1525which returns C<($x + $y)> as a
1526L<PPI::Structure::List|PPI::Structure::List> instance.
14a6a3ef 1527
14a6a3ef 1528
6d9feae6 1529=item C<parse_arg_list( $element )>
59b05e08 1530
11f53956
ES
1531Given a L<PPI::Element|PPI::Element> that is presumed to be a function
1532call (which is usually a L<PPI::Token::Word|PPI::Token::Word>), splits
1533the argument expressions into arrays of tokens. Returns a list
1534containing references to each of those arrays. This is useful because
1535parentheses are optional when calling a function, and PPI parses them
1536very differently. So this method is a poor-man's parse tree of PPI
1537nodes. It's not bullet-proof because it doesn't respect precedence.
1538In general, I don't like the way this function works, so don't count
1539on it to be stable (or even present).
1540
59b05e08 1541
c6e19b74
CD
1542=item C<split_nodes_on_comma( @nodes )>
1543
11f53956
ES
1544This has the same return type as C<parse_arg_list()> but expects to be
1545passed the nodes that represent the interior of a list, like:
1546
1547 'foo', 1, 2, 'bar'
c6e19b74 1548
c6e19b74 1549
6d9feae6 1550=item C<is_script( $document )>
bf159007 1551
11f53956
ES
1552Given a L<PPI::Document|PPI::Document>, test if it starts with
1553C</#!.*/>. If so, it is judged to be a script instead of a module.
deb58212
JRT
1554Also, if the filename of the document ends in ".PL" then it is
1555also judged to be a script. However, this only works if the
1556document is a L<PPI::Document::File|PPI::Document::File>. If it
1557isn't, then the filename is not available and it has no bearing on
1558how the document is judged.
11f53956
ES
1559See C<shebang_line()>.
1560
bf159007 1561
464d4c66
ES
1562=item C<is_in_void_context( $token )>
1563
11f53956
ES
1564Given a L<PPI::Token|PPI::Token>, answer whether it appears to be in a
1565void context.
1566
464d4c66 1567
9f12283e 1568=item C<policy_long_name( $policy_name )>
dc93df4f 1569
bbf4108c
ES
1570Given a policy class name in long or short form, return the long form.
1571
11f53956 1572
9f12283e 1573=item C<policy_short_name( $policy_name )>
bbf4108c 1574
11f53956
ES
1575Given a policy class name in long or short form, return the short
1576form.
1577
dc93df4f 1578
8645eb2c
JRT
1579=item C<all_perl_files( @directories )>
1580
11f53956
ES
1581Given a list of directories, recursively searches through all the
1582directories (depth first) and returns a list of paths for all the
1583files that are Perl code files. Any administrative files for CVS or
1584Subversion are skipped, as are things that look like temporary or
1585backup files.
8645eb2c
JRT
1586
1587A Perl code file is:
1588
1589=over 4
1590
1591=item * Any file that ends in F<.PL>, F<.pl>, F<.pm>, or F<.t>
1592
1593=item * Any file that has a first line with a shebang containing 'perl'
1594
1595=back
1596
11f53956 1597
0bcb38c0
JRT
1598=item C<severity_to_number( $severity )>
1599
11f53956
ES
1600If C<$severity> is given as an integer, this function returns
1601C<$severity> but normalized to lie between C<$SEVERITY_LOWEST> and
1602C<$SEVERITY_HIGHEST>. If C<$severity> is given as a string, this
1603function returns the corresponding severity number. If the string
1604doesn't have a corresponding number, this function will throw an
1605exception.
1606
0bcb38c0 1607
2e0f1c94
ES
1608=item C<is_valid_numeric_verbosity( $severity )>
1609
1610Answers whether the argument has a translation to a Violation format.
1611
11f53956 1612
4268e673
JRT
1613=item C<verbosity_to_format( $verbosity_level )>
1614
11f53956
ES
1615Given a verbosity level between 1 and 10, returns the corresponding
1616predefined format string. These formats are suitable for passing to
1617the C<set_format> method in
1618L<Perl::Critic::Violation|Perl::Critic::Violation>. See the
1619L<perlcritic|perlcritic> documentation for a listing of the predefined
1620formats.
1621
4268e673 1622
3ffdaa3b
AL
1623=item C<hashify( @list )>
1624
11f53956
ES
1625Given C<@list>, return a hash where C<@list> is in the keys and each
1626value is 1. Duplicate values in C<@list> are silently squished.
1627
7b84ff16
JRT
1628
1629=item C<interpolate( $literal )>
1630
11f53956
ES
1631Given a C<$literal> string that may contain control characters (e.g..
1632'\t' '\n'), this function does a double interpolation on the string
1633and returns it as if it had been declared in double quotes. For
1634example:
1635
1636 'foo \t bar \n' ...becomes... "foo \t bar \n"
7b84ff16 1637
3ffdaa3b 1638
e2e7b907
CD
1639=item C<shebang_line( $document )>
1640
11f53956
ES
1641Given a L<PPI::Document|PPI::Document>, test if it starts with C<#!>.
1642If so, return that line. Otherwise return undef.
1643
e2e7b907 1644
4a7a7227
AL
1645=item C<words_from_string( $str )>
1646
11f53956
ES
1647Given config string I<$str>, return all the words from the string.
1648This is safer than splitting on whitespace.
1649
4a7a7227 1650
9fb2d1dc
AM
1651=item C<is_unchecked_call( $element )>
1652
11f53956
ES
1653Given a L<PPI::Element|PPI::Element>, test to see if it contains a
1654function call whose return value is not checked.
1655
9fb2d1dc 1656
59b05e08
JRT
1657=back
1658
11f53956 1659
bbf4108c 1660=head1 IMPORTABLE VARIABLES
59b05e08
JRT
1661
1662=over 8
1663
6d9feae6 1664=item C<$COMMA>
59b05e08 1665
a3adb7a9
AL
1666=item C<$FATCOMMA>
1667
6d9feae6 1668=item C<$COLON>
59b05e08 1669
6d9feae6 1670=item C<$SCOLON>
59b05e08 1671
6d9feae6 1672=item C<$QUOTE>
59b05e08 1673
6d9feae6 1674=item C<$DQUOTE>
59b05e08 1675
68a933bc
ES
1676=item C<$BACKTICK>
1677
6d9feae6 1678=item C<$PERIOD>
59b05e08 1679
6d9feae6 1680=item C<$PIPE>
59b05e08 1681
6d9feae6 1682=item C<$EMPTY>
59b05e08 1683
6d9feae6 1684=item C<$SPACE>
59b05e08 1685
a609ec83
ES
1686=item C<$SLASH>
1687
1688=item C<$BSLASH>
1689
310e7cf9
ES
1690=item C<$LEFT_PAREN>
1691
1692=item C<$RIGHT_PAREN>
1693
11f53956
ES
1694These character constants give clear names to commonly-used strings
1695that can be hard to read when surrounded by quotes and other
1696punctuation. Can be imported in one go via the C<:characters> tag.
dff08b70 1697
6d9feae6 1698=item C<$SEVERITY_HIGHEST>
dff08b70 1699
6d9feae6 1700=item C<$SEVERITY_HIGH>
dff08b70 1701
6d9feae6 1702=item C<$SEVERITY_MEDIUM>
dff08b70 1703
6d9feae6 1704=item C<$SEVERITY_LOW>
dff08b70 1705
6d9feae6 1706=item C<$SEVERITY_LOWEST>
dff08b70 1707
7e86d49a 1708These numeric constants define the relative severity of violating each
11f53956
ES
1709L<Perl::Critic::Policy|Perl::Critic::Policy>. The C<get_severity> and
1710C<default_severity> methods of every Policy subclass must return one
1711of these values. Can be imported via the C<:severities> tag.
dff08b70 1712
738830ba
ES
1713=item C<$DEFAULT_VERBOSITY>
1714
1715The default numeric verbosity.
1716
1717=item C<$DEFAULT_VERBOSITY_WITH_FILE_NAME>
1718
1719The numeric verbosity that corresponds to the format indicated by
1720C<$DEFAULT_VERBOSITY>, but with the file name prefixed to it.
1721
6d9feae6 1722=item C<$TRUE>
59b05e08 1723
6d9feae6 1724=item C<$FALSE>
59b05e08 1725
11f53956
ES
1726These are simple booleans. 1 and 0 respectively. Be mindful of using
1727these with string equality. C<$FALSE ne $EMPTY>. Can be imported via
1728the C<:booleans> tag.
1729
bbf4108c
ES
1730
1731=back
1732
11f53956 1733
bbf4108c
ES
1734=head1 IMPORT TAGS
1735
11f53956
ES
1736The following groups of functions and constants are available as
1737parameters to a C<use Perl::Critic::Util> statement.
bbf4108c
ES
1738
1739=over
1740
1741=item C<:all>
1742
1743The lot.
1744
11f53956 1745
bbf4108c
ES
1746=item C<:booleans>
1747
1748Includes:
1749C<$TRUE>, C<$FALSE>
1750
11f53956 1751
bbf4108c
ES
1752=item C<:severities>
1753
1754Includes:
1755C<$SEVERITY_HIGHEST>,
1756C<$SEVERITY_HIGH>,
1757C<$SEVERITY_MEDIUM>,
1758C<$SEVERITY_LOW>,
1759C<$SEVERITY_LOWEST>,
1760C<@SEVERITY_NAMES>
1761
11f53956 1762
bbf4108c
ES
1763=item C<:characters>
1764
1765Includes:
1766C<$COLON>,
1767C<$COMMA>,
1768C<$DQUOTE>,
1769C<$EMPTY>,
1770C<$FATCOMMA>,
1771C<$PERIOD>,
1772C<$PIPE>,
1773C<$QUOTE>,
68a933bc 1774C<$BACKTICK>,
bbf4108c
ES
1775C<$SCOLON>,
1776C<$SPACE>,
1777C<$SLASH>,
1778C<$BSLASH>
310e7cf9
ES
1779C<$LEFT_PAREN>
1780C<$RIGHT_PAREN>
bbf4108c 1781
11f53956 1782
bbf4108c
ES
1783=item C<:classification>
1784
1785Includes:
70f3f307
ES
1786C<is_function_call>,
1787C<is_hash_key>,
1788C<is_included_module_name>,
1789C<is_integer>,
1790C<is_method_call>,
1791C<is_package_declaration>,
1792C<is_perl_builtin>,
1793C<is_perl_global>,
1794C<is_perl_builtin_with_list_context>
1795C<is_perl_builtin_with_multiple_arguments>
1796C<is_perl_builtin_with_no_arguments>
1797C<is_perl_builtin_with_one_argument>
1798C<is_perl_builtin_with_optional_argument>
1799C<is_perl_builtin_with_zero_and_or_one_arguments>
1800C<is_script>,
1801C<is_subroutine_name>,
1802C<is_unchecked_call>
1803C<is_valid_numeric_verbosity>
bbf4108c 1804
11f53956
ES
1805See also L<Perl::Critic::Utils::PPI|Perl::Critic::Utils::PPI>.
1806
9f12283e 1807
bbf4108c
ES
1808=item C<:data_conversion>
1809
11f53956
ES
1810Generic manipulation, not having anything specific to do with
1811Perl::Critic.
bbf4108c
ES
1812
1813Includes:
70f3f307
ES
1814C<hashify>,
1815C<words_from_string>,
1816C<interpolate>
bbf4108c 1817
11f53956 1818
bbf4108c
ES
1819=item C<:ppi>
1820
11f53956 1821Things for dealing with L<PPI|PPI>, other than classification.
bbf4108c
ES
1822
1823Includes:
70f3f307
ES
1824C<first_arg>,
1825C<parse_arg_list>
bbf4108c 1826
11f53956
ES
1827See also L<Perl::Critic::Utils::PPI|Perl::Critic::Utils::PPI>.
1828
9f12283e 1829
bbf4108c
ES
1830=item C<:internal_lookup>
1831
1832Translations between internal representations.
1833
1834Includes:
70f3f307
ES
1835C<severity_to_number>,
1836C<verbosity_to_format>
bbf4108c 1837
11f53956 1838
bbf4108c
ES
1839=item C<:language>
1840
1841Information about Perl not programmatically available elsewhere.
1842
1843Includes:
70f3f307 1844C<precedence_of>
bbf4108c 1845
11f53956 1846
bbf4108c
ES
1847=item C<:deprecated>
1848
11f53956
ES
1849Not surprisingly, things that are deprecated. It is preferred to use
1850this tag to get to these functions, rather than the function names
1851themselves, so as to mark any module using them as needing cleanup.
bbf4108c
ES
1852
1853Includes:
70f3f307 1854C<find_keywords>
59b05e08 1855
11f53956 1856
59b05e08
JRT
1857=back
1858
11f53956 1859
9f12283e
ES
1860=head1 SEE ALSO
1861
11f53956
ES
1862L<Perl::Critic::Utils::Constants|Perl::Critic::Utils::Constants>,
1863L<Perl::Critic::Utils::McCabe|Perl::Critic::Utils::McCabe>,
1864L<Perl::Critic::Utils::PPI|Perl::Critic::Utils::PPI>,
1865
9f12283e 1866
59b05e08
JRT
1867=head1 AUTHOR
1868
1869Jeffrey Ryan Thalhammer <thaljef@cpan.org>
1870
11f53956 1871
59b05e08
JRT
1872=head1 COPYRIGHT
1873
20dfddeb 1874Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. All rights reserved.
59b05e08
JRT
1875
1876This program is free software; you can redistribute it and/or modify
1877it under the same terms as Perl itself. The full text of this license
1878can be found in the LICENSE file included with this module.
dff08b70
JRT
1879
1880=cut
737d3b65
CD
1881
1882# Local Variables:
1883# mode: cperl
1884# cperl-indent-level: 4
1885# fill-column: 78
1886# indent-tabs-mode: nil
1887# c-indentation-style: bsd
1888# End:
96fed375 1889# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :