Login
Modified is_method_call() so it can be used to detect barewords on
[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
59b05e08
JRT
8package Perl::Critic::Utils;
9
10use strict;
11use warnings;
c948abe5 12
0bcb38c0 13use Carp qw(confess);
410cf90b 14use File::Spec qw();
c948abe5 15use Scalar::Util qw( blessed );
e2d4c0f0 16use B::Keywords qw();
c948abe5 17
59b05e08
JRT
18use base 'Exporter';
19
a65bc95d 20our $VERSION = 1.05;
59b05e08 21
6036a254 22#-----------------------------------------------------------------------------
bbf4108c 23# Exportable symbols here.
1fe8e187 24
bbf4108c 25our @EXPORT_OK = qw(
dc93df4f
JRT
26 $TRUE
27 $FALSE
28
e2d4c0f0
JRT
29 $POLICY_NAMESPACE
30
dc93df4f
JRT
31 $SEVERITY_HIGHEST
32 $SEVERITY_HIGH
33 $SEVERITY_MEDIUM
34 $SEVERITY_LOW
35 $SEVERITY_LOWEST
0bcb38c0 36 @SEVERITY_NAMES
dc93df4f
JRT
37
38 $COLON
39 $COMMA
40 $DQUOTE
41 $EMPTY
42 $FATCOMMA
43 $PERIOD
44 $PIPE
45 $QUOTE
46 $SCOLON
47 $SPACE
a609ec83
ES
48 $SLASH
49 $BSLASH
310e7cf9
ES
50 $LEFT_PAREN
51 $RIGHT_PAREN
6f31806e 52
dc93df4f
JRT
53 &all_perl_files
54 &find_keywords
bbf4108c 55 &first_arg
dc93df4f 56 &hashify
7b84ff16 57 &interpolate
dc93df4f 58 &is_function_call
6f31806e 59 &is_hash_key
0893757b 60 &is_included_module_name
dc93df4f 61 &is_method_call
bdaf4dac 62 &is_package_declaration
6f31806e 63 &is_perl_builtin
3ca95ec9 64 &is_perl_bareword
c948abe5
ES
65 &is_perl_builtin_with_list_context
66 &is_perl_builtin_with_multiple_arguments
27ac78c7
ES
67 &is_perl_builtin_with_no_arguments
68 &is_perl_builtin_with_one_argument
69 &is_perl_builtin_with_optional_argument
70 &is_perl_builtin_with_zero_and_or_one_arguments
6f31806e 71 &is_perl_global
dc93df4f 72 &is_script
6f31806e 73 &is_subroutine_name
bbf4108c 74 &is_unchecked_call
6f31806e 75 &parse_arg_list
dc93df4f
JRT
76 &policy_long_name
77 &policy_short_name
6f31806e 78 &precedence_of
0bcb38c0 79 &severity_to_number
bbf4108c 80 &shebang_line
dc93df4f 81 &verbosity_to_format
4a7a7227 82 &words_from_string
bbf4108c
ES
83);
84
7cb05702
JRT
85
86# Note: this is deprecated.
87our @EXPORT = @EXPORT_OK; ## no critic (ProhibitAutomaticExport)
88
5feaec1d 89
bbf4108c
ES
90our %EXPORT_TAGS = (
91 all => [ @EXPORT_OK ],
92 booleans => [ qw{ $TRUE $FALSE } ],
93 severities => [
94 qw{
95 $SEVERITY_HIGHEST
96 $SEVERITY_HIGH
97 $SEVERITY_MEDIUM
98 $SEVERITY_LOW
99 $SEVERITY_LOWEST
100 @SEVERITY_NAMES
101 }
102 ],
103 characters => [
104 qw{
105 $COLON
106 $COMMA
107 $DQUOTE
108 $EMPTY
109 $FATCOMMA
110 $PERIOD
111 $PIPE
112 $QUOTE
113 $SCOLON
114 $SPACE
115 $SLASH
116 $BSLASH
310e7cf9
ES
117 $LEFT_PAREN
118 $RIGHT_PAREN
bbf4108c
ES
119 }
120 ],
121 classification => [
122 qw{
123 &is_function_call
124 &is_hash_key
0893757b 125 &is_included_module_name
bbf4108c 126 &is_method_call
bdaf4dac 127 &is_package_declaration
bbf4108c
ES
128 &is_perl_builtin
129 &is_perl_global
3ca95ec9 130 &is_perl_bareword
c948abe5
ES
131 &is_perl_builtin_with_list_context
132 &is_perl_builtin_with_multiple_arguments
27ac78c7
ES
133 &is_perl_builtin_with_no_arguments
134 &is_perl_builtin_with_one_argument
135 &is_perl_builtin_with_optional_argument
136 &is_perl_builtin_with_zero_and_or_one_arguments
bbf4108c
ES
137 &is_script
138 &is_subroutine_name
139 &is_unchecked_call
140 }
141 ],
142 data_conversion => [ qw{ &hashify &words_from_string &interpolate } ],
143 ppi => [ qw{ &first_arg &parse_arg_list } ],
144 internal_lookup => [ qw{ &severity_to_number &verbosity_to_format } ],
145 language => [ qw{ &precedence_of } ],
146 deprecated => [ qw{ &find_keywords } ],
59b05e08
JRT
147);
148
6036a254 149#-----------------------------------------------------------------------------
59b05e08 150
1fe8e187
JRT
151our $POLICY_NAMESPACE = 'Perl::Critic::Policy';
152
6036a254 153#-----------------------------------------------------------------------------
1fe8e187 154
7e86d49a
JRT
155our $SEVERITY_HIGHEST = 5;
156our $SEVERITY_HIGH = 4;
157our $SEVERITY_MEDIUM = 3;
158our $SEVERITY_LOW = 2;
159our $SEVERITY_LOWEST = 1;
dff08b70 160
6036a254 161#-----------------------------------------------------------------------------
6b4a61e9 162
310e7cf9
ES
163our $COMMA = q{,};
164our $FATCOMMA = q{=>};
165our $COLON = q{:};
166our $SCOLON = q{;};
167our $QUOTE = q{'};
168our $DQUOTE = q{"};
169our $PERIOD = q{.};
170our $PIPE = q{|};
171our $SPACE = q{ };
172our $SLASH = q{/};
173our $BSLASH = q{\\};
174our $LEFT_PAREN = q{(};
175our $RIGHT_PAREN = q{)};
176our $EMPTY = q{};
177our $TRUE = 1;
178our $FALSE = 0;
59b05e08 179
6036a254 180#-----------------------------------------------------------------------------
6b4a61e9 181
8d6b89b3
JRT
182#TODO: Should this include punctuations vars?
183
59b05e08 184
8d6b89b3 185
6036a254 186#-----------------------------------------------------------------------------
dc93df4f 187## no critic (ProhibitNoisyQuotes);
57973330 188
8d6b89b3 189my %PRECEDENCE_OF = (
d0dd0a1a
JRT
190 '->' => 1, '<' => 10, '//' => 15, '.=' => 19,
191 '++' => 2, '>' => 10, '||' => 15, '^=' => 19,
192 '--' => 2, '<=' => 10, '..' => 16, '<<=' => 19,
193 '**' => 3, '>=' => 10, '...' => 17, '>>=' => 19,
194 '!' => 4, 'lt' => 10, '?' => 18, ',' => 20,
195 '~' => 4, 'gt' => 10, ':' => 18, '=>' => 20,
196 '\\' => 4, 'le' => 10, '=' => 19, 'not' => 22,
197 '=~' => 5, 'ge' => 10, '+=' => 19, 'and' => 23,
198 '!~' => 5, '==' => 11, '-=' => 19, 'or' => 24,
199 '*' => 6, '!=' => 11, '*=' => 19, 'xor' => 24,
200 '/' => 6, '<=>' => 11, '/=' => 19,
201 '%' => 6, 'eq' => 11, '%=' => 19,
202 'x' => 6, 'ne' => 11, '||=' => 19,
203 '+' => 7, 'cmp' => 11, '&&=' => 19,
204 '-' => 7, '&' => 12, '|=' => 19,
205 '.' => 7, '|' => 13, '&=' => 19,
206 '<<' => 8, '^' => 13, '**=' => 19,
207 '>>' => 8, '&&' => 14, 'x=' => 19,
8d6b89b3
JRT
208);
209
57973330 210## use critic
7b84ff16 211#-----------------------------------------------------------------------------
8d6b89b3 212
3ffdaa3b
AL
213sub hashify {
214 return map { $_ => 1 } @_;
215}
216
7b84ff16
JRT
217#-----------------------------------------------------------------------------
218
219sub interpolate {
220 my ( $literal ) = @_;
221 return eval "\"$literal\""; ## no critic 'StringyEval';
222}
223
224#-----------------------------------------------------------------------------
3ffdaa3b 225
59b05e08
JRT
226sub find_keywords {
227 my ( $doc, $keyword ) = @_;
45acb16b
CD
228 my $nodes_ref = $doc->find('PPI::Token::Word');
229 return if !$nodes_ref;
59b05e08
JRT
230 my @matches = grep { $_ eq $keyword } @{$nodes_ref};
231 return @matches ? \@matches : undef;
232}
233
7b84ff16 234#-----------------------------------------------------------------------------
c948abe5
ES
235
236sub _name_for_sub_or_stringified_element {
237 my $elem = shift;
238
239 if ( blessed $elem and $elem->isa('PPI::Statement::Sub') ) {
240 return $elem->name();
241 }
242
243 return "$elem";
244}
245
246#-----------------------------------------------------------------------------
207c8eb0 247## no critic (ProhibitPackageVars)
dff08b70 248
e2d4c0f0
JRT
249my %BUILTINS = hashify( @B::Keywords::Functions );
250
8d6b89b3 251sub is_perl_builtin {
45acb16b
CD
252 my $elem = shift;
253 return if !$elem;
c948abe5
ES
254
255 return exists $BUILTINS{ _name_for_sub_or_stringified_element($elem) };
8d6b89b3 256}
36f7994c 257
7b84ff16 258#-----------------------------------------------------------------------------
8d6b89b3 259
3ca95ec9
JRT
260my %BAREWORDS = hashify( @B::Keywords::Barewords );
261
262sub is_perl_bareword {
263 my $elem = shift;
264 return if !$elem;
265
266 return exists $BAREWORDS{ _name_for_sub_or_stringified_element($elem) };
267}
268
269#-----------------------------------------------------------------------------
270
207c8eb0 271my @GLOBALS_WITHOUT_SIGILS = map { substr $_, 1 } @B::Keywords::Arrays,
e2d4c0f0
JRT
272 @B::Keywords::Hashes,
273 @B::Keywords::Scalars;
274
275my %GLOBALS= hashify( @GLOBALS_WITHOUT_SIGILS );
276
8d6b89b3 277sub is_perl_global {
45acb16b
CD
278 my $elem = shift;
279 return if !$elem;
3c71d40c
JRT
280 my $var_name = "$elem"; #Convert Token::Symbol to string
281 $var_name =~ s{\A [\$@%] }{}mx; #Chop off the sigil
282 return exists $GLOBALS{ $var_name };
8d6b89b3
JRT
283}
284
207c8eb0 285## use critic
7b84ff16 286#-----------------------------------------------------------------------------
8d6b89b3 287
c948abe5
ES
288# egrep '=item.*LIST' perlfunc.pod
289my %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT =
290 hashify(
291 qw{
292 chmod
293 chown
294 die
295 exec
296 formline
297 grep
298 import
299 join
300 kill
301 map
302 no
303 open
304 pack
305 print
306 printf
307 push
308 reverse
19d26f4f 309 say
c948abe5
ES
310 sort
311 splice
312 sprintf
313 syscall
314 system
315 tie
316 unlink
317 unshift
318 use
319 utime
320 warn
27ac78c7 321 },
c948abe5
ES
322 );
323
324sub is_perl_builtin_with_list_context {
325 my $elem = shift;
326
327 return
328 exists
329 $BUILTINS_WHICH_PROVIDE_LIST_CONTEXT{
330 _name_for_sub_or_stringified_element($elem)
331 };
332}
333
334#-----------------------------------------------------------------------------
335
336# egrep '=item.*[A-Z],' perlfunc.pod
337my %BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS =
338 hashify(
339 qw{
340 accept
341 atan2
342 bind
343 binmode
344 bless
345 connect
346 crypt
347 dbmopen
348 fcntl
349 flock
350 gethostbyaddr
351 getnetbyaddr
352 getpriority
353 getservbyname
354 getservbyport
355 getsockopt
356 index
357 ioctl
358 link
359 listen
360 mkdir
361 msgctl
362 msgget
363 msgrcv
364 msgsnd
365 open
366 opendir
367 pipe
368 read
369 recv
370 rename
371 rindex
372 seek
373 seekdir
374 select
375 semctl
376 semget
377 semop
378 send
379 setpgrp
380 setpriority
381 setsockopt
382 shmctl
383 shmget
384 shmread
385 shmwrite
386 shutdown
387 socket
388 socketpair
389 splice
390 split
391 substr
392 symlink
393 sysopen
394 sysread
395 sysseek
396 syswrite
397 truncate
398 unpack
399 vec
400 waitpid
401 },
402 keys %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT
403 );
404
405sub is_perl_builtin_with_multiple_arguments {
406 my $elem = shift;
407
408 return
409 exists
410 $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{
411 _name_for_sub_or_stringified_element($elem)
412 };
413}
414
415#-----------------------------------------------------------------------------
416
27ac78c7
ES
417my %BUILTINS_WHICH_TAKE_NO_ARGUMENTS =
418 hashify(
419 qw{
420 endgrent
421 endhostent
422 endnetent
423 endprotoent
424 endpwent
425 endservent
426 fork
427 format
428 getgrent
429 gethostent
430 getlogin
431 getnetent
432 getppid
433 getprotoent
434 getpwent
435 getservent
436 setgrent
437 setpwent
438 split
439 time
440 times
441 wait
442 wantarray
443 }
444 );
445
446sub is_perl_builtin_with_no_arguments {
447 my $elem = shift;
448
449 return
450 exists
451 $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{
452 _name_for_sub_or_stringified_element($elem)
453 };
454}
455
456#-----------------------------------------------------------------------------
457
458my %BUILTINS_WHICH_TAKE_ONE_ARGUMENT =
459 hashify(
460 qw{
461 closedir
462 dbmclose
463 delete
464 each
465 exists
466 fileno
467 getgrgid
468 getgrnam
469 gethostbyname
470 getnetbyname
471 getpeername
472 getpgrp
473 getprotobyname
474 getprotobynumber
475 getpwnam
476 getpwuid
477 getsockname
478 goto
479 keys
480 local
481 prototype
482 readdir
483 readline
484 readpipe
485 rewinddir
486 scalar
487 sethostent
488 setnetent
489 setprotoent
490 setservent
491 telldir
492 tied
493 untie
494 values
495 }
496 );
497
498sub is_perl_builtin_with_one_argument {
499 my $elem = shift;
500
501 return
502 exists
503 $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{
504 _name_for_sub_or_stringified_element($elem)
505 };
506}
507
508#-----------------------------------------------------------------------------
509
510## no critic (ProhibitPackageVars)
511my %BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT =
512 hashify(
513 grep { not exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $_ } }
514 grep { not exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $_ } }
515 grep { not exists $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{ $_ } }
516 @B::Keywords::Functions
517 );
518## use critic
519
520sub is_perl_builtin_with_optional_argument {
521 my $elem = shift;
522
523 return
524 exists
525 $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{
526 _name_for_sub_or_stringified_element($elem)
527 };
528}
529
530#-----------------------------------------------------------------------------
531
532sub is_perl_builtin_with_zero_and_or_one_arguments {
533 my $elem = shift;
8e2aefdb 534
27ac78c7
ES
535 return if not $elem;
536
537 my $name = _name_for_sub_or_stringified_element($elem);
538
539 return (
540 exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $name }
541 or exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $name }
542 or exists $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{ $name }
543 );
544}
545
546#-----------------------------------------------------------------------------
547
8d6b89b3 548sub precedence_of {
45acb16b
CD
549 my $elem = shift;
550 return if !$elem;
3c71d40c 551 return $PRECEDENCE_OF{ ref $elem ? "$elem" : $elem };
8d6b89b3
JRT
552}
553
7b84ff16 554#-----------------------------------------------------------------------------
8d6b89b3 555
59b05e08
JRT
556sub is_hash_key {
557 my $elem = shift;
45acb16b 558 return if !$elem;
59b05e08
JRT
559
560 #Check curly-brace style: $hash{foo} = bar;
45acb16b
CD
561 my $parent = $elem->parent();
562 return if !$parent;
563 my $grandparent = $parent->parent();
564 return if !$grandparent;
59b05e08
JRT
565 return 1 if $grandparent->isa('PPI::Structure::Subscript');
566
567
568 #Check declarative style: %hash = (foo => bar);
45acb16b
CD
569 my $sib = $elem->snext_sibling();
570 return if !$sib;
59b05e08
JRT
571 return 1 if $sib->isa('PPI::Token::Operator') && $sib eq '=>';
572
45acb16b 573 return;
59b05e08
JRT
574}
575
7b84ff16 576#-----------------------------------------------------------------------------
dff08b70 577
0893757b
ES
578sub is_included_module_name {
579 my $elem = shift;
580 return if !$elem;
581 my $stmnt = $elem->statement();
582 return if !$stmnt;
583 return if !$stmnt->isa('PPI::Statement::Include');
584 return $stmnt->schild(1) == $elem;
585}
586
587#-----------------------------------------------------------------------------
588
59b05e08
JRT
589sub is_method_call {
590 my $elem = shift;
45acb16b 591 return if !$elem;
8053d374
JRT
592
593 return 1 if _is_dereference_operator( $elem->sprevious_sibling() );
594 return 1 if _is_dereference_operator( $elem->snext_sibling() );
595 return;
596}
597
598#-----------------------------------------------------------------------------
599
600sub _is_dereference_operator {
601 my $elem = shift;
602 return if !$elem;
603
604 return $elem->isa('PPI::Token::Operator') && $elem eq q{->};
59b05e08
JRT
605}
606
7b84ff16 607#-----------------------------------------------------------------------------
dff08b70 608
bdaf4dac
ES
609sub is_package_declaration {
610 my $elem = shift;
611 return if !$elem;
612 my $stmnt = $elem->statement();
613 return if !$stmnt;
614 return if !$stmnt->isa('PPI::Statement::Package');
615 return $stmnt->schild(1) == $elem;
616}
617
618#-----------------------------------------------------------------------------
619
0c377685
JRT
620sub is_subroutine_name {
621 my $elem = shift;
45acb16b
CD
622 return if !$elem;
623 my $sib = $elem->sprevious_sibling();
624 return if !$sib;
625 my $stmnt = $elem->statement();
626 return if !$stmnt;
0c377685
JRT
627 return $stmnt->isa('PPI::Statement::Sub') && $sib eq 'sub';
628}
629
7b84ff16 630#-----------------------------------------------------------------------------
0c377685 631
dc118d1b
JRT
632sub is_function_call {
633 my $elem = shift;
3ca95ec9
JRT
634 return if ! $elem;
635
636 return if is_hash_key($elem);
637 return if is_method_call($elem);
638 return if is_subroutine_name($elem);
639 return if is_included_module_name($elem);
640 return if is_package_declaration($elem);
641 return if is_perl_bareword($elem);
642
643 return 1;
dc118d1b
JRT
644}
645
7b84ff16 646#-----------------------------------------------------------------------------
dc118d1b 647
dff08b70
JRT
648sub is_script {
649 my $doc = shift;
e992086d
AL
650
651 return shebang_line($doc) ? 1 : 0;
dff08b70
JRT
652}
653
7b84ff16 654#-----------------------------------------------------------------------------
dff08b70 655
dc93df4f 656sub policy_long_name {
1fe8e187
JRT
657 my ( $policy_name ) = @_;
658 if ( $policy_name !~ m{ \A $POLICY_NAMESPACE }mx ) {
659 $policy_name = $POLICY_NAMESPACE . q{::} . $policy_name;
dc93df4f
JRT
660 }
661 return $policy_name;
662}
663
7b84ff16 664#-----------------------------------------------------------------------------
dc93df4f
JRT
665
666sub policy_short_name {
1fe8e187
JRT
667 my ( $policy_name ) = @_;
668 $policy_name =~ s{\A $POLICY_NAMESPACE ::}{}mx;
dc93df4f
JRT
669 return $policy_name;
670}
671
7b84ff16 672#-----------------------------------------------------------------------------
dc93df4f 673
14a6a3ef
CD
674sub first_arg {
675 my $elem = shift;
676 my $sib = $elem->snext_sibling();
677 return if !$sib;
678
679 if ( $sib->isa('PPI::Structure::List') ) {
680
681 my $expr = $sib->schild(0);
682 return if !$expr;
683 return $expr->isa('PPI::Statement') ? $expr->schild(0) : $expr;
684 }
685
686 return $sib;
687}
688
689#-----------------------------------------------------------------------------
690
59b05e08
JRT
691sub parse_arg_list {
692 my $elem = shift;
45acb16b
CD
693 my $sib = $elem->snext_sibling();
694 return if !$sib;
59b05e08
JRT
695
696 if ( $sib->isa('PPI::Structure::List') ) {
697
0a6f07d0 698 #Pull siblings from list
45acb16b
CD
699 my $expr = $sib->schild(0);
700 return if !$expr;
0a6f07d0 701 return _split_nodes_on_comma( $expr->schildren() );
59b05e08
JRT
702 }
703 else {
704
0a6f07d0
AL
705 #Gather up remaining nodes in the statement
706 my $iter = $elem;
707 my @arg_list = ();
59b05e08 708
0a6f07d0
AL
709 while ($iter = $iter->snext_sibling() ) {
710 last if $iter->isa('PPI::Token::Structure') and $iter eq $SCOLON;
711 push @arg_list, $iter;
712 }
713 return _split_nodes_on_comma( @arg_list );
59b05e08
JRT
714 }
715}
716
dff08b70
JRT
717#---------------------------------
718
59b05e08
JRT
719sub _split_nodes_on_comma {
720 my @nodes = ();
721 my $i = 0;
722 for my $node (@_) {
6f31806e
AL
723 if ( $node->isa('PPI::Token::Operator') &&
724 (($node eq $COMMA) || ($node eq $FATCOMMA)) ) {
0a6f07d0
AL
725 $i++; #Move forward to next 'node stack'
726 next;
727 }
40ec8029 728 push @{ $nodes[$i] }, $node;
59b05e08
JRT
729 }
730 return @nodes;
731}
bf159007 732
8645eb2c
JRT
733#-----------------------------------------------------------------------------
734
4268e673
JRT
735my %FORMAT_OF = (
736 1 => "%f:%l:%c:%m\n",
737 2 => "%f: (%l:%c) %m\n",
b57cebc1
JRT
738 3 => "%m at %f line %l\n",
739 4 => "%m at line %l, column %c. %e. (Severity: %s)\n",
740 5 => "%f: %m at line %l, column %c. %e. (Severity: %s)\n",
741 6 => "%m at line %l, near '%r'. (Severity: %s)\n",
742 7 => "%f: %m at line %l near '%r'. (Severity: %s)\n",
743 8 => "[%p] %m at line %l, column %c. (Severity: %s)\n",
744 9 => "[%p] %m at line %l, near '%r'. (Severity: %s)\n",
745 10 => "%m at line %l, column %c.\n %p (Severity: %s)\n%d\n",
746 11 => "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n",
4268e673
JRT
747);
748
9f6df1c1
JRT
749my $DEFAULT_FORMAT = $FORMAT_OF{4};
750
4268e673 751sub verbosity_to_format {
9f6df1c1
JRT
752 my ($verbosity) = @_;
753 return $DEFAULT_FORMAT if not defined $verbosity;
754 return $FORMAT_OF{abs int $verbosity} || $DEFAULT_FORMAT if _is_integer($verbosity);
755 return interpolate( $verbosity ); #Otherwise, treat as a format spec
4268e673
JRT
756}
757
9f6df1c1
JRT
758sub _is_integer { return $_[0] =~ m{ \A [+-]? \d+ \z }mx }
759
4268e673
JRT
760#-----------------------------------------------------------------------------
761
0bcb38c0
JRT
762my %SEVERITY_NUMBER_OF = (
763 gentle => 5,
764 stern => 4,
765 harsh => 3,
766 cruel => 2,
767 brutal => 1,
768);
769
770our @SEVERITY_NAMES = sort { $SEVERITY_NUMBER_OF{$a} <=> $SEVERITY_NUMBER_OF{$b} }
771 keys %SEVERITY_NUMBER_OF; #This is exported!
772
773sub severity_to_number {
774 my ($severity) = @_;
775 return _normalize_severity( $severity ) if _is_integer( $severity );
776 my $severity_number = $SEVERITY_NUMBER_OF{lc $severity};
777 confess qq{Invalid severity: "$severity"} if not defined $severity_number;
778 return $severity_number;
779}
780
781sub _normalize_severity {
782 my $s = shift || return $SEVERITY_HIGHEST;
783 $s = $s > $SEVERITY_HIGHEST ? $SEVERITY_HIGHEST : $s;
784 $s = $s < $SEVERITY_LOWEST ? $SEVERITY_LOWEST : $s;
785 return $s;
786}
787
788#-----------------------------------------------------------------------------
789
a91b8a46
AL
790my @skip_dir = qw( CVS RCS .svn _darcs {arch} .bzr _build blib );
791my %skip_dir = hashify( @skip_dir );
792
8645eb2c
JRT
793sub all_perl_files {
794
795 # Recursively searches a list of directories and returns the paths
796 # to files that seem to be Perl source code. This subroutine was
797 # poached from Test::Perl::Critic.
798
8645eb2c
JRT
799 my @queue = @_;
800 my @code_files = ();
801
802 while (@queue) {
803 my $file = shift @queue;
804 if ( -d $file ) {
805 opendir my ($dh), $file or next;
806 my @newfiles = sort readdir $dh;
807 closedir $dh;
808
809 @newfiles = File::Spec->no_upwards(@newfiles);
810 @newfiles = grep { !$skip_dir{$_} } @newfiles;
811 push @queue, map { File::Spec->catfile($file, $_) } @newfiles;
812 }
813
814 if ( (-f $file) && ! _is_backup($file) && _is_perl($file) ) {
815 push @code_files, $file;
816 }
817 }
818 return @code_files;
819}
820
821
822#-----------------------------------------------------------------------------
823# Decide if it's some sort of backup file
824
825sub _is_backup {
826 my ($file) = @_;
827 return 1 if $file =~ m{ [.] swp \z}mx;
828 return 1 if $file =~ m{ [.] bak \z}mx;
829 return 1 if $file =~ m{ ~ \z}mx;
830 return 1 if $file =~ m{ \A [#] .+ [#] \z}mx;
831 return;
832}
833
834#-----------------------------------------------------------------------------
835# Returns true if the argument ends with a perl-ish file
836# extension, or if it has a shebang-line containing 'perl' This
837# subroutine was also poached from Test::Perl::Critic
838
839sub _is_perl {
840 my ($file) = @_;
841
842 #Check filename extensions
843 return 1 if $file =~ m{ [.] PL \z}mx;
844 return 1 if $file =~ m{ [.] p (?: l|m ) \z}mx;
845 return 1 if $file =~ m{ [.] t \z}mx;
846
847 #Check for shebang
848 open my ($fh), '<', $file or return;
849 my $first = <$fh>;
9fb2d1dc 850 close $fh or confess "unable to close $file: $!";
8645eb2c 851
e2e7b907 852 return 1 if defined $first && ( $first =~ m{ \A \#![ ]*\S*perl }mx );
8645eb2c
JRT
853 return;
854}
855
6036a254 856#-----------------------------------------------------------------------------
bf159007 857
e2e7b907
CD
858sub shebang_line {
859 my $doc = shift;
860 my $first_comment = $doc->find_first('PPI::Token::Comment');
861 return if !$first_comment;
862 my $location = $first_comment->location();
863 return if !$location;
864 # The shebang must be the first two characters in the file, according to
865 # http://en.wikipedia.org/wiki/Shebang_(Unix)
866 return if $location->[0] != 1; # line number
867 return if $location->[1] != 1; # column number
868 my $shebang = $first_comment->content;
869 return if $shebang !~ m{ \A \#\! }mx;
870 return $shebang;
871}
872
6036a254 873#-----------------------------------------------------------------------------
e2e7b907 874
4a7a7227
AL
875sub words_from_string {
876 my $str = shift;
877
38e3d924 878 return split q{ }, $str; # This must be a literal space, not $SPACE
4a7a7227
AL
879}
880
9fb2d1dc
AM
881#-----------------------------------------------------------------------------
882
883sub is_unchecked_call {
884 my $elem = shift;
885
886 return if not is_function_call( $elem );
887
888 # check to see if there's an '=' or 'unless' or something before this.
889 if( my $sib = $elem->sprevious_sibling() ){
890 return if $sib;
891 }
892
893
894 if( my $statement = $elem->statement() ){
895
896 # "open or die" is OK.
897 # We can't check snext_sibling for 'or' since the next siblings are an
898 # unknown number of arguments to the system call. Instead, check all of
40647aca
JRT
899 # the elements to this statement to see if we find 'or' or '||'.
900
901 my $or_operators = sub {
902 my (undef, $elem) = @_;
903 return if not $elem->isa('PPI::Token::Operator');
0f1f4df7 904 return if $elem ne q{or} && $elem ne q{||};
40647aca
JRT
905 return 1;
906 };
907
908 return if $statement->find( $or_operators );
909
9fb2d1dc
AM
910
911 if( my $parent = $elem->statement()->parent() ){
912
40647aca 913 # Check if we're in an if( open ) {good} else {bad} condition
9fb2d1dc
AM
914 return if $parent->isa('PPI::Structure::Condition');
915
40647aca 916 # Return val could be captured in data structure and checked later
9fb2d1dc
AM
917 return if $parent->isa('PPI::Structure::Constructor');
918
919 # "die if not ( open() )" - It's in list context.
920 if ( $parent->isa('PPI::Structure::List') ) {
921 if( my $uncle = $parent->sprevious_sibling() ){
922 return if $uncle;
923 }
924 }
925 }
926 }
927
928 # Otherwise, return. this system call is unchecked.
929 return 1;
930}
931
4a7a7227 932
59b05e08
JRT
9331;
934
935__END__
936
dff08b70
JRT
937=pod
938
59b05e08
JRT
939=head1 NAME
940
941Perl::Critic::Utils - Utility subs and vars for Perl::Critic
942
943=head1 DESCRIPTION
944
bbf4108c
ES
945This module provides several static subs and variables that are useful for
946developing L<Perl::Critic::Policy> subclasses. Unless you are writing Policy
947modules, you probably don't care about this package.
59b05e08 948
bbf4108c 949=head1 IMPORTABLE SUBS
59b05e08
JRT
950
951=over 8
952
6d9feae6 953=item C<find_keywords( $doc, $keyword )>
59b05e08 954
bbf4108c
ES
955B<DEPRECATED:> Since version 0.11, every Policy is evaluated at each element
956of the document. So you shouldn't need to go looking for a particular
957keyword. If you I<do> want to use this, please import it via the
958C<:deprecated> tag, rather than directly, to mark the module as needing
959updating.
59b05e08 960
6d9feae6 961Given a L<PPI::Document> as C<$doc>, returns a reference to an array
bbf4108c
ES
962containing all the L<PPI::Token::Word> elements that match C<$keyword>. This
963can be used to find any built-in function, method call, bareword, or reserved
964keyword. It will not match variables, subroutine names, literal strings,
965numbers, or symbols. If the document doesn't contain any matches, returns
966undef.
59b05e08 967
8d6b89b3
JRT
968=item C<is_perl_global( $element )>
969
3c71d40c 970Given a L<PPI::Token::Symbol> or a string, returns true if that token
bbf4108c
ES
971represents one of the global variables provided by the L<English> module, or
972one of the builtin global variables like C<%SIG>, C<%ENV>, or C<@ARGV>. The
973sigil on the symbol is ignored, so things like C<$ARGV> or C<$ENV> will still
974return true.
8d6b89b3
JRT
975
976=item C<is_perl_builtin( $element )>
977
c948abe5
ES
978Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
979if that token represents a call to any of the builtin functions defined in
980Perl 5.8.8.
981
3ca95ec9
JRT
982=item C<is_perl_bareword( $element )>
983
984Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
985if that token represents a bareword (e.g. "if", "else", "sub", "package")
986defined in Perl 5.8.8.
987
c948abe5
ES
988=item C<is_perl_builtin_with_list_context( $element )>
989
990Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
991if that token represents a call to any of the builtin functions defined in
27ac78c7 992Perl 5.8.8 that provide a list context to the following tokens.
c948abe5
ES
993
994=item C<is_perl_builtin_with_multiple_arguments( $element )>
995
996Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
997if that token represents a call to any of the builtin functions defined in
27ac78c7
ES
998Perl 5.8.8 that B<can> take multiple arguments.
999
1000=item C<is_perl_builtin_with_no_arguments( $element )>
1001
1002Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1003if that token represents a call to any of the builtin functions defined in
1004Perl 5.8.8 that B<cannot> take any arguments.
1005
1006=item C<is_perl_builtin_with_one_argument( $element )>
1007
1008Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1009if that token represents a call to any of the builtin functions defined in
1010Perl 5.8.8 that takes B<one and only one> argument.
1011
1012=item C<is_perl_builtin_with_optional_argument( $element )>
1013
1014Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1015if that token represents a call to any of the builtin functions defined in
1016Perl 5.8.8 that takes B<no more than one> argument.
1017
1018The sets of values for which C<is_perl_builtin_with_multiple_arguments()>,
1019C<is_perl_builtin_with_no_arguments()>,
1020C<is_perl_builtin_with_one_argument()>, and
1021C<is_perl_builtin_with_optional_argument()> return true are disjoint and
1022their union is precisely the set of values that C<is_perl_builtin()> will
1023return true for.
1024
1025=item C<is_perl_builtin_with_zero_and_or_one_arguments( $element )>
1026
1027Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
1028if that token represents a call to any of the builtin functions defined in
1029Perl 5.8.8 that takes no and/or one argument.
1030
1031Returns true if any of C<is_perl_builtin_with_no_arguments()>,
1032C<is_perl_builtin_with_one_argument()>, and
1033C<is_perl_builtin_with_optional_argument()> returns true.
8d6b89b3
JRT
1034
1035=item C<precedence_of( $element )>
1036
bbf4108c
ES
1037Given a L<PPI::Token::Operator> or a string, returns the precedence of the
1038operator, where 1 is the highest precedence. Returns undef if the precedence
1039can't be determined (which is usually because it is not an operator).
8d6b89b3 1040
6d9feae6 1041=item C<is_hash_key( $element )>
59b05e08 1042
bbf4108c
ES
1043Given a L<PPI::Element>, returns true if the element is a hash key. PPI
1044doesn't distinguish between regular barewords (like keywords or subroutine
1045calls) and barewords in hash subscripts (which are considered literal). So
1046this subroutine is useful if your Policy is searching for L<PPI::Token::Word>
1047elements and you want to filter out the hash subscript variety. In both of
1048the following examples, 'foo' is considered a hash key:
59b05e08
JRT
1049
1050 $hash1{foo} = 1;
1051 %hash2 = (foo => 1);
1052
bdaf4dac
ES
1053=item C<is_included_module_name( $element )>
1054
1055Given a L<PPI::Token::Word>, returns true if the element is the name of a
1056module that is being included via C<use>, C<require>, or C<no>.
1057
6d9feae6 1058=item C<is_method_call( $element )>
59b05e08 1059
8053d374
JRT
1060Given a L<PPI::Token::Word>, returns true if there the element that
1061immediately preceeds or follows the given element is the dereference operator
1062"->". When a bareword has a "->" on either side of it, it usually (always?)
1063means that it is part of a method call. This is useful for distinguishing
1064static function calls from object method calls.
59b05e08 1065
bdaf4dac 1066=item C<is_package_declaration( $element )>
0c377685 1067
bbf4108c 1068Given a L<PPI::Token::Word>, returns true if the element is the name of a
bdaf4dac 1069package that is being declared.
0c377685 1070
bdaf4dac 1071=item C<is_subroutine_name( $element )>
0893757b
ES
1072
1073Given a L<PPI::Token::Word>, returns true if the element is the name of a
bdaf4dac
ES
1074subroutine declaration. This is useful for distinguishing barewords and from
1075function calls from subroutine declarations.
0893757b 1076
dc118d1b
JRT
1077=item C<is_function_call( $element )>
1078
bbf4108c
ES
1079Given a L<PPI::Token::Word> returns true if the element appears to be call to
1080a static function. Specifically, this function returns true if
3ca95ec9
JRT
1081C<is_hash_key>, C<is_method_call>, C<is_subroutine_name>,
1082C<is_included_module_anme>, C<is_package_declaration>, C<is_perl_bareword>,
1083and C<is_subroutine_name> all return false for the given element.
dc118d1b 1084
14a6a3ef
CD
1085=item C<first_arg( $element )>
1086
1087Given a L<PPI::Element> that is presumed to be a function call (which is
bbf4108c
ES
1088usually a L<PPI::Token::Word>), return the first argument. This is similar of
1089C<parse_arg_list()> and follows the same logic. Note that for the code:
14a6a3ef
CD
1090
1091 int($x + 0.5)
1092
1093this function will return just the C<$x>, not the whole expression. This is
1094different from the behavior of C<parse_arg_list()>. Another caveat is:
1095
1096 int(($x + $y) + 0.5)
1097
1098which returns C<($x + $y)> as a L<PPI::Structure::List> instance.
1099
6d9feae6 1100=item C<parse_arg_list( $element )>
59b05e08 1101
bbf4108c
ES
1102Given a L<PPI::Element> that is presumed to be a function call (which is
1103usually a L<PPI::Token::Word>), splits the argument expressions into arrays of
1104tokens. Returns a list containing references to each of those arrays. This
1105is useful because parens are optional when calling a function, and PPI parses
1106them very differently. So this method is a poor-man's parse tree of PPI
1107nodes. It's not bullet-proof because it doesn't respect precedence. In
1108general, I don't like the way this function works, so don't count on it to be
1109stable (or even present).
59b05e08 1110
6d9feae6 1111=item C<is_script( $document )>
bf159007 1112
bbf4108c
ES
1113Given a L<PPI::Document>, test if it starts with C</#!.*/>. If so, it is
1114judged to be a script instead of a module. See C<shebang_line()>.
bf159007 1115
bbf4108c 1116=item C< policy_long_name( $policy_name ) >
dc93df4f 1117
bbf4108c
ES
1118Given a policy class name in long or short form, return the long form.
1119
1120=item C< policy_short_name( $policy_name ) >
1121
1122Given a policy class name in long or short form, return the short form.
dc93df4f 1123
8645eb2c
JRT
1124=item C<all_perl_files( @directories )>
1125
bbf4108c
ES
1126Given a list of directories, recursively searches through all the directories
1127(depth first) and returns a list of paths for all the files that are Perl code
1128files. Any administrative files for CVS or Subversion are skipped, as are
1129things that look like temporary or backup files.
8645eb2c
JRT
1130
1131A Perl code file is:
1132
1133=over 4
1134
1135=item * Any file that ends in F<.PL>, F<.pl>, F<.pm>, or F<.t>
1136
1137=item * Any file that has a first line with a shebang containing 'perl'
1138
1139=back
1140
0bcb38c0
JRT
1141=item C<severity_to_number( $severity )>
1142
1143If C<$severity> is given as an integer, this function returns C<$severity> but
1144normalized to lie between C<$SEVERITY_LOWEST> and C<$SEVERITY_HIGHEST>. If
1145C<$severity> is given as a string, this function returns the corresponding
1146severity number. If the string doesn't have a corresponding number, this
1147function will throw an exception.
1148
4268e673
JRT
1149=item C<verbosity_to_format( $verbosity_level )>
1150
bbf4108c
ES
1151Given a verbosity level between 1 and 10, returns the corresponding predefined
1152format string. These formats are suitable for passing to the C<set_format>
1153method in L<Perl::Critic::Violation>. See the L<perlcritic> documentation for
1154a listing of the predefined formats.
4268e673 1155
3ffdaa3b
AL
1156=item C<hashify( @list )>
1157
bbf4108c
ES
1158Given C<@list>, return a hash where C<@list> is in the keys and each value is
11591. Duplicate values in C<@list> are silently squished.
7b84ff16
JRT
1160
1161=item C<interpolate( $literal )>
1162
bbf4108c
ES
1163Given a C<$literal> string that may contain control characters (e.g.. '\t'
1164'\n'), this function does a double interpolation on the string and returns it
1165as if it had been declared in double quotes. For example:
7b84ff16
JRT
1166
1167 'foo \t bar \n' ...becomes... "foo \t bar \n"
3ffdaa3b 1168
e2e7b907
CD
1169=item C<shebang_line( $document )>
1170
bbf4108c
ES
1171Given a L<PPI::Document>, test if it starts with C<#!>. If so, return that
1172line. Otherwise return undef.
e2e7b907 1173
4a7a7227
AL
1174=item C<words_from_string( $str )>
1175
bbf4108c
ES
1176Given config string I<$str>, return all the words from the string. This is
1177safer than splitting on whitespace.
4a7a7227 1178
9fb2d1dc
AM
1179=item C<is_unchecked_call( $element )>
1180
1181Given a L<PPI::Element>, test to see if it contains a function call whose
1182return value is not checked.
1183
59b05e08
JRT
1184=back
1185
bbf4108c 1186=head1 IMPORTABLE VARIABLES
59b05e08
JRT
1187
1188=over 8
1189
6d9feae6 1190=item C<$COMMA>
59b05e08 1191
a3adb7a9
AL
1192=item C<$FATCOMMA>
1193
6d9feae6 1194=item C<$COLON>
59b05e08 1195
6d9feae6 1196=item C<$SCOLON>
59b05e08 1197
6d9feae6 1198=item C<$QUOTE>
59b05e08 1199
6d9feae6 1200=item C<$DQUOTE>
59b05e08 1201
6d9feae6 1202=item C<$PERIOD>
59b05e08 1203
6d9feae6 1204=item C<$PIPE>
59b05e08 1205
6d9feae6 1206=item C<$EMPTY>
59b05e08 1207
6d9feae6 1208=item C<$SPACE>
59b05e08 1209
a609ec83
ES
1210=item C<$SLASH>
1211
1212=item C<$BSLASH>
1213
310e7cf9
ES
1214=item C<$LEFT_PAREN>
1215
1216=item C<$RIGHT_PAREN>
1217
bbf4108c
ES
1218These character constants give clear names to commonly-used strings that can
1219be hard to read when surrounded by quotes and other punctuation. Can be
1220imported in one go via the C<:characters> tag.
dff08b70 1221
6d9feae6 1222=item C<$SEVERITY_HIGHEST>
dff08b70 1223
6d9feae6 1224=item C<$SEVERITY_HIGH>
dff08b70 1225
6d9feae6 1226=item C<$SEVERITY_MEDIUM>
dff08b70 1227
6d9feae6 1228=item C<$SEVERITY_LOW>
dff08b70 1229
6d9feae6 1230=item C<$SEVERITY_LOWEST>
dff08b70 1231
7e86d49a 1232These numeric constants define the relative severity of violating each
bbf4108c
ES
1233L<Perl::Critic::Policy>. The C<get_severity> and C<default_severity> methods
1234of every Policy subclass must return one of these values. Can be imported via
1235the C<:severities> tag.
dff08b70 1236
6d9feae6 1237=item C<$TRUE>
59b05e08 1238
6d9feae6 1239=item C<$FALSE>
59b05e08
JRT
1240
1241These are simple booleans. 1 and 0 respectively. Be mindful of using these
bbf4108c
ES
1242with string equality. C<$FALSE ne $EMPTY>. Can be imported via the
1243C<:booleans> tag.
1244
1245=back
1246
1247=head1 IMPORT TAGS
1248
1249The following groups of functions and constants are available as parameters to
1250a C<use Perl::Critic::Util> statement.
1251
1252=over
1253
1254=item C<:all>
1255
1256The lot.
1257
1258=item C<:booleans>
1259
1260Includes:
1261C<$TRUE>, C<$FALSE>
1262
1263=item C<:severities>
1264
1265Includes:
1266C<$SEVERITY_HIGHEST>,
1267C<$SEVERITY_HIGH>,
1268C<$SEVERITY_MEDIUM>,
1269C<$SEVERITY_LOW>,
1270C<$SEVERITY_LOWEST>,
1271C<@SEVERITY_NAMES>
1272
1273=item C<:characters>
1274
1275Includes:
1276C<$COLON>,
1277C<$COMMA>,
1278C<$DQUOTE>,
1279C<$EMPTY>,
1280C<$FATCOMMA>,
1281C<$PERIOD>,
1282C<$PIPE>,
1283C<$QUOTE>,
1284C<$SCOLON>,
1285C<$SPACE>,
1286C<$SLASH>,
1287C<$BSLASH>
310e7cf9
ES
1288C<$LEFT_PAREN>
1289C<$RIGHT_PAREN>
bbf4108c
ES
1290
1291=item C<:classification>
1292
1293Includes:
1294C<&is_function_call>,
1295C<&is_hash_key>,
0893757b 1296C<&is_included_module_name>,
bbf4108c 1297C<&is_method_call>,
bdaf4dac 1298C<&is_package_declaration>,
bbf4108c
ES
1299C<&is_perl_builtin>,
1300C<&is_perl_global>,
1301C<&is_script>,
1302C<&is_subroutine_name>,
1303C<&is_unchecked_call>
1304
1305=item C<:data_conversion>
1306
1307Generic manipulation, not having anything specific to do with Perl::Critic.
1308
1309Includes:
1310C<&hashify>,
1311C<&words_from_string>,
1312C<&interpolate>
1313
1314=item C<:ppi>
1315
1316Things for dealing with L<PPI>, other than classification.
1317
1318Includes:
1319C<&first_arg>,
1320C<&parse_arg_list>
1321
1322=item C<:internal_lookup>
1323
1324Translations between internal representations.
1325
1326Includes:
1327C<&severity_to_number>,
1328C<&verbosity_to_format>
1329
1330=item C<:language>
1331
1332Information about Perl not programmatically available elsewhere.
1333
1334Includes:
1335C<&precedence_of>
1336
1337=item C<:deprecated>
1338
1339Not surprisingly, things that are deprecated. It is preferred to use this tag
1340to get to these functions, rather than the function names themselves, so as to
1341mark any module using them as needing cleanup.
1342
1343Includes:
1344C<&find_keywords>
59b05e08
JRT
1345
1346=back
1347
1348=head1 AUTHOR
1349
1350Jeffrey Ryan Thalhammer <thaljef@cpan.org>
1351
1352=head1 COPYRIGHT
1353
0d5b2dca 1354Copyright (c) 2005-2007 Jeffrey Ryan Thalhammer. All rights reserved.
59b05e08
JRT
1355
1356This program is free software; you can redistribute it and/or modify
1357it under the same terms as Perl itself. The full text of this license
1358can be found in the LICENSE file included with this module.
dff08b70
JRT
1359
1360=cut
737d3b65
CD
1361
1362# Local Variables:
1363# mode: cperl
1364# cperl-indent-level: 4
1365# fill-column: 78
1366# indent-tabs-mode: nil
1367# c-indentation-style: bsd
1368# End:
345c7562 1369# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab :