Login
Fixed the no-critic comments to allow the disabling of just the subroutine name....
[gknop/Perl-Critic.git] / lib / Perl / Critic / Utils.pm
CommitLineData
39cd321a
JRT
1#######################################################################
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
6########################################################################
7
59b05e08
JRT
8package Perl::Critic::Utils;
9
10use strict;
11use warnings;
12use base 'Exporter';
13
ca1d77d1 14our $VERSION = '0.15_02';
59b05e08
JRT
15$VERSION = eval $VERSION; ## no critic
16
7e86d49a 17#---------------------------------------------------------------------------
59b05e08
JRT
18# Exported symbols here
19
20our @EXPORT =
0c377685
JRT
21 qw(@GLOBALS $COMMA &find_keywords $SEVERITY_HIGHEST
22 @BUILTINS $COLON &is_hash_key $SEVERITY_HIGH
23 $SCOLON &is_method_call $SEVERITY_MEDIUM
24 $QUOTE &parse_arg_list $SEVERITY_LOW
25 $DQUOTE &is_script $SEVERITY_LOWEST
8d6b89b3
JRT
26 $SPACE &precedence_of
27 $PIPE &is_perl_builtin
28 $TRUE $PERIOD &is_perl_global
0c377685 29 $FALSE $EMPTY &is_subroutine_name
59b05e08
JRT
30);
31
32#---------------------------------------------------------------------------
33
7e86d49a
JRT
34our $SEVERITY_HIGHEST = 5;
35our $SEVERITY_HIGH = 4;
36our $SEVERITY_MEDIUM = 3;
37our $SEVERITY_LOW = 2;
38our $SEVERITY_LOWEST = 1;
dff08b70
JRT
39
40#---------------------------------------------------------------------------
59b05e08
JRT
41our $COMMA = q{,};
42our $COLON = q{:};
43our $SCOLON = q{;};
44our $QUOTE = q{'};
45our $DQUOTE = q{"};
46our $PERIOD = q{.};
47our $PIPE = q{|};
48our $SPACE = q{ };
49our $EMPTY = q{};
50our $TRUE = 1;
51our $FALSE = 0;
52
53#---------------------------------------------------------------------------
54our @BUILTINS =
55 qw(abs exp int readdir socket wantarray
56 accept fcntl ioctl readline socketpair warn
57 alarm fileno join readlink sort write
58 atan2 flock keys readpipe splice
59 bind fork kill recv split
60 binmode format last redo sprintf
61 bless formline lc ref sqrt
62 caller getc lcfirst rename srand
63 chdir getgrent length require stat
64 chmod getgrgid link reset study
65 chomp getgrnam listen return sub
66 chop gethostbyaddr local reverse substr
67 chown gethostbyname localtime rewinddir symlink
68 chr gethostent log rindex syscall
69 chroot getlogin lstat rmdir sysopen
70 close getnetbyaddr map scalar sysread
71 closedir getnetbyname mkdir seek sysseek
72 connect getnetent msgctl seekdir system
73 continue getpeername msgget select syswrite
74 cos getpgrp msgrcv semctl tell
75 crypt getppid msgsnd semget telldir
76 dbmclose getpriority next semop tie
77 dbmopen getprotobyname no send tied
78 defined getprotobynumber oct setgrent time
79 delete getprotoent open sethostent times
80 die getpwent opendir setnetent truncate
81 do getpwnam ord setpgrp uc
82 dump getpwuid our setpriority ucfirst
83 each getservbyname pack setprotoent umask
84 endgrent getservbyport package setpwent undef
85 endhostent getservent pipe setservent unlink
86 endnetent getsockname pop setsockopt unpack
87 endprotoent getsockopt pos shift unshift
88 endpwent glob print shmctl untie
89 endservent gmtime printf shmget use
90 eof goto prototype shmread utime
91 eval grep push shmwrite values
92 exec hex quotemeta shutdown vec
93 exists import rand sin wait
94 exit index read sleep waitpid
95);
96
8d6b89b3 97#Hashify
cf6f1e1f 98my %BUILTINS = map { $_ => 1 } @BUILTINS;
8d6b89b3 99
59b05e08
JRT
100#---------------------------------------------------------------------------
101
8d6b89b3
JRT
102#TODO: Should this include punctuations vars?
103
59b05e08
JRT
104our @GLOBALS =
105 qw(ACCUMULATOR INPLACE_EDIT
106 BASETIME INPUT_LINE_NUMBER NR
107 CHILD_ERROR INPUT_RECORD_SEPARATOR RS
108 COMPILING LAST_MATCH_END
109 DEBUGGING LAST_REGEXP_CODE_RESULT
110 EFFECTIVE_GROUP_ID EGID LIST_SEPARATOR
111 EFFECTIVE_USER_ID EUID OS_ERROR
112 ENV OSNAME
113 EVAL_ERROR OUTPUT_AUTOFLUSH
114 ERRNO OUTPUT_FIELD_SEPARATOR OFS
115 EXCEPTIONS_BEING_CAUGHT OUTPUT_RECORD_SEPARATOR ORS
116 EXECUTABLE_NAME PERL_VERSION
117 EXTENDED_OS_ERROR PROGRAM_NAME
118 FORMAT_FORMFEED REAL_GROUP_ID GID
119 FORMAT_LINE_BREAK_CHARACTERS REAL_USER_ID UID
120 FORMAT_LINES_LEFT SIG
121 FORMAT_LINES_PER_PAGE SUBSCRIPT_SEPARATOR SUBSEP
122 FORMAT_NAME SYSTEM_FD_MAX
123 FORMAT_PAGE_NUMBER WARNING
124 FORMAT_TOP_NAME PERLDB
125 INC ARGV
126);
127
8d6b89b3 128#Hashify
cf6f1e1f 129my %GLOBALS = map { $_ => 1 } @GLOBALS;
8d6b89b3
JRT
130
131#-------------------------------------------------------------------------
d66846f3 132## no critic 'ProhibitNoisyQuotes';
57973330 133
8d6b89b3
JRT
134my %PRECEDENCE_OF = (
135 '->' => 1, '<' => 10, '||' => 15,
136 '++' => 2, '>' => 10, '..' => 16,
137 '--' => 2, '<=' => 10, '...' => 17,
36f7994c
JRT
138 '**' => 3, '>=' => 10, '?' => 18,
139 '!' => 4, 'lt' => 10, ':' => 18,
140 '~' => 4, 'gt' => 10, '=' => 19,
141 '\\' => 4, 'le' => 10, '+=' => 19,
142 '=~' => 5, 'ge' => 10, '-=' => 19,
143 '!~' => 5, '==' => 11, '*=' => 19,
144 '*' => 6, '!=' => 11, ',' => 20,
145 '/' => 6, '<=>' => 11, '=>' => 20,
146 '%' => 6, 'eq' => 11, 'not' => 22,
147 'x' => 6, 'ne' => 11, 'and' => 23,
148 '+' => 7, 'cmp' => 11, 'or' => 24,
149 '-' => 7, '&' => 12, 'xor' => 24,
8d6b89b3
JRT
150 '.' => 7, '|' => 13,
151 '<<' => 8, '^' => 13,
152 '>>' => 8, '&&' => 14,
153);
154
57973330 155## use critic
8d6b89b3
JRT
156#-------------------------------------------------------------------------
157
158our %UNARY_OPS = ();
159
59b05e08
JRT
160#-------------------------------------------------------------------------
161
162sub find_keywords {
163 my ( $doc, $keyword ) = @_;
164 my $nodes_ref = $doc->find('PPI::Token::Word') || return;
165 my @matches = grep { $_ eq $keyword } @{$nodes_ref};
166 return @matches ? \@matches : undef;
167}
168
dff08b70
JRT
169#-------------------------------------------------------------------------
170
8d6b89b3 171sub is_perl_builtin {
a7753069 172 my $elem = shift || return;
cf6f1e1f
JRT
173 my $name = $elem->isa('PPI::Statement::Sub') ? $elem->name() : $elem;
174 return exists $BUILTINS{ $name };
8d6b89b3 175}
36f7994c 176
8d6b89b3
JRT
177#-------------------------------------------------------------------------
178
179sub is_perl_global {
a7753069 180 my $elem = shift || return;
3c71d40c
JRT
181 my $var_name = "$elem"; #Convert Token::Symbol to string
182 $var_name =~ s{\A [\$@%] }{}mx; #Chop off the sigil
183 return exists $GLOBALS{ $var_name };
8d6b89b3
JRT
184}
185
186#-------------------------------------------------------------------------
187
188sub precedence_of {
a7753069 189 my $elem = shift || return;
3c71d40c 190 return $PRECEDENCE_OF{ ref $elem ? "$elem" : $elem };
8d6b89b3
JRT
191}
192
193#-------------------------------------------------------------------------
194
59b05e08
JRT
195sub is_hash_key {
196 my $elem = shift;
197
198 #Check curly-brace style: $hash{foo} = bar;
199 my $parent = $elem->parent() || return;
200 my $grandparent = $parent->parent() || return;
201 return 1 if $grandparent->isa('PPI::Structure::Subscript');
202
203
204 #Check declarative style: %hash = (foo => bar);
205 my $sib = $elem->snext_sibling() || return;
206 return 1 if $sib->isa('PPI::Token::Operator') && $sib eq '=>';
207
208 return 0;
209}
210
dff08b70
JRT
211#-------------------------------------------------------------------------
212
59b05e08
JRT
213sub is_method_call {
214 my $elem = shift;
215 my $sib = $elem->sprevious_sibling() || return;
216 return $sib->isa('PPI::Token::Operator') && $sib eq q{->};
217}
218
dff08b70
JRT
219#-------------------------------------------------------------------------
220
0c377685
JRT
221sub is_subroutine_name {
222 my $elem = shift;
223 my $sib = $elem->sprevious_sibling () || return;
224 my $stmnt = $elem->statement() || return;
225 return $stmnt->isa('PPI::Statement::Sub') && $sib eq 'sub';
226}
227
228#-------------------------------------------------------------------------
229
dff08b70
JRT
230sub is_script {
231 my $doc = shift;
232 my $first_comment = $doc->find_first('PPI::Token::Comment') || return;
233 $first_comment->location()->[0] == 1 || return;
234 return $first_comment =~ m{ \A \#\! }mx;
235}
236
237#-------------------------------------------------------------------------
238
59b05e08
JRT
239sub parse_arg_list {
240 my $elem = shift;
241 my $sib = $elem->snext_sibling() || return;
242
243 if ( $sib->isa('PPI::Structure::List') ) {
244
245 #Pull siblings from list
246 my $expr = $sib->schild(0) || return;
247 return _split_nodes_on_comma( $expr->schildren() );
248 }
249 else {
250
251 #Gather up remaining nodes in the statement
252 my $iter = $elem;
253 my @arg_list = ();
254
255 while ($iter = $iter->snext_sibling() ) {
256 last if $iter->isa('PPI::Token::Structure') and $iter eq $SCOLON;
257 push @arg_list, $iter;
258 }
259 return _split_nodes_on_comma( @arg_list );
260 }
261}
262
dff08b70
JRT
263#---------------------------------
264
59b05e08
JRT
265sub _split_nodes_on_comma {
266 my @nodes = ();
267 my $i = 0;
268 for my $node (@_) {
269 if ( $node->isa('PPI::Token::Operator') && $node eq $COMMA ) {
270 $i++; #Move forward to next 'node stack'
271 next;
272 }
273
dff08b70
JRT
274 #Push onto current 'node stack', or create a new 'stack'
275 if ( defined $nodes[$i] ) {
59b05e08
JRT
276 push @{ $nodes[$i] }, $node;
277 }
278 else {
279 $nodes[$i] = [$node];
280 }
281 }
282 return @nodes;
283}
bf159007 284
dff08b70 285#-------------------------------------------------------------------------
bf159007 286
59b05e08
JRT
2871;
288
289__END__
290
dff08b70
JRT
291=pod
292
59b05e08
JRT
293=head1 NAME
294
295Perl::Critic::Utils - Utility subs and vars for Perl::Critic
296
297=head1 DESCRIPTION
298
6d9feae6
JRT
299This module exports several static subs and variables that are useful
300for developing L<Perl::Critic::Policy> subclasses. Unless you are
301writing Policy modules, you probably don't care about this package.
59b05e08
JRT
302
303=head1 EXPORTED SUBS
304
305=over 8
306
6d9feae6 307=item C<find_keywords( $doc, $keyword )>
59b05e08 308
8d6b89b3
JRT
309B<DEPRECATED:> Since version 0.11, every Policy is evaluated at each
310element of the document. So you shouldn't need to go looking for a
36f7994c 311particular keyword.
59b05e08 312
6d9feae6 313Given a L<PPI::Document> as C<$doc>, returns a reference to an array
59b05e08
JRT
314containing all the L<PPI::Token::Word> elements that match
315C<$keyword>. This can be used to find any built-in function, method
316call, bareword, or reserved keyword. It will not match variables,
317subroutine names, literal strings, numbers, or symbols. If the
318document doesn't contain any matches, returns undef.
319
8d6b89b3
JRT
320=item C<is_perl_global( $element )>
321
3c71d40c
JRT
322Given a L<PPI::Token::Symbol> or a string, returns true if that token
323represents one of the global variables provided by the L<English>
324module, or one of the builtin global variables like C<%SIG>, C<%ENV>,
325or C<@ARGV>. The sigil on the symbol is ignored, so things like
326C<$ARGV> or C<$ENV> will still return true.
8d6b89b3
JRT
327
328=item C<is_perl_builtin( $element )>
329
3c71d40c
JRT
330Given a L<PPI::Token::Word> or a string, returns true if that token
331represents a call to any of the builtin functions defined in Perl
3325.8.8
8d6b89b3
JRT
333
334=item C<precedence_of( $element )>
335
3c71d40c
JRT
336Given a L<PPI::Token::Operator> or a string, returns the precedence of
337the operator, where 1 is the highest precedence. Returns undef if the
338precedence can't be determined (which is usually because it is not an
339operator).
8d6b89b3 340
6d9feae6 341=item C<is_hash_key( $element )>
59b05e08
JRT
342
343Given a L<PPI::Element>, returns true if the element is a hash key.
344PPI doesn't distinguish between regular barewords (like keywords or
345subroutine calls) and barewords in hash subscripts (which are
346considered literal). So this subroutine is useful if your Policy is
347searching for L<PPI::Token::Word> elements and you want to filter out
348the hash subscript variety. In both of the following examples, 'foo'
349is considered a hash key:
350
351 $hash1{foo} = 1;
352 %hash2 = (foo => 1);
353
6d9feae6 354=item C<is_method_call( $element )>
59b05e08
JRT
355
356Given a L<PPI::Element> that is presumed to be a function call (which
6d9feae6 357is usually a L<PPI::Token::Word>), returns true if the function is a
b2c7354a
JRT
358method being called on some reference. Basically, it just looks to see
359if the preceding operator is "->". This is useful for distinguishing
6d9feae6 360static function calls from object method calls.
59b05e08 361
0c377685
JRT
362=item C<is_subroutine_name( $element )>
363
364Given a L<PPI::Token::Word>, returns true if the element is the name
e2ec15ae
JRT
365of a subroutine declaration. This is useful for distinguishing
366barewords and from function calls from subroutine declarations.
0c377685 367
6d9feae6 368=item C<parse_arg_list( $element )>
59b05e08
JRT
369
370Given a L<PPI::Element> that is presumed to be a function call (which
371is usually a L<PPI::Token::Word>), splits the argument expressions
372into arrays of tokens. Returns a list containing references to each
373of those arrays. This is useful because parens are optional when
374calling a function, and PPI parses them very differently. So this
375method is a poor-man's parse tree of PPI nodes. It's not bullet-proof
376because it doesn't respect precedence. In general, I don't like the
377way this function works, so don't count on it to be stable (or even
378present).
379
6d9feae6 380=item C<is_script( $document )>
bf159007 381
6d9feae6 382Given a L<PPI::Document>, test if it starts with C</#!.*perl/>. If so,
bf159007
JRT
383it is judged to be a script instead of a module.
384
59b05e08
JRT
385=back
386
387=head1 EXPORTED VARIABLES
388
389=over 8
390
6d9feae6 391=item C<@BUILTINS>
59b05e08 392
8d6b89b3
JRT
393B<DEPRECATED:> Use C<is_perl_builtin()> instead.
394
59b05e08
JRT
395This is a list of all the built-in functions provided by Perl 5.8. I
396imagine this is useful for distinguishing native and non-native
8d6b89b3 397function calls.
59b05e08 398
6d9feae6 399=item C<@GLOBALS>
59b05e08 400
8d6b89b3
JRT
401B<DEPRECATED:> Use C<is_perl_global()> instead.
402
59b05e08
JRT
403This is a list of all the magic global variables provided by the
404L<English> module. Also includes commonly-used global like C<%SIG>,
405C<%ENV>, and C<@ARGV>. The list contains only the variable name,
406without the sigil.
407
6d9feae6 408=item C<$COMMA>
59b05e08 409
6d9feae6 410=item C<$COLON>
59b05e08 411
6d9feae6 412=item C<$SCOLON>
59b05e08 413
6d9feae6 414=item C<$QUOTE>
59b05e08 415
6d9feae6 416=item C<$DQUOTE>
59b05e08 417
6d9feae6 418=item C<$PERIOD>
59b05e08 419
6d9feae6 420=item C<$PIPE>
59b05e08 421
6d9feae6 422=item C<$EMPTY>
59b05e08 423
6d9feae6 424=item C<$SPACE>
59b05e08 425
dff08b70
JRT
426These character constants give clear names to commonly-used strings
427that can be hard to read when surrounded by quotes.
428
6d9feae6 429=item C<$SEVERITY_HIGHEST>
dff08b70 430
6d9feae6 431=item C<$SEVERITY_HIGH>
dff08b70 432
6d9feae6 433=item C<$SEVERITY_MEDIUM>
dff08b70 434
6d9feae6 435=item C<$SEVERITY_LOW>
dff08b70 436
6d9feae6 437=item C<$SEVERITY_LOWEST>
dff08b70 438
7e86d49a 439These numeric constants define the relative severity of violating each
6d9feae6
JRT
440L<Perl::Critic::Policy>. The C<get_severity> and C<default_severity>
441methods of every Policy subclass must return one of these values.
dff08b70 442
6d9feae6 443=item C<$TRUE>
59b05e08 444
6d9feae6 445=item C<$FALSE>
59b05e08
JRT
446
447These are simple booleans. 1 and 0 respectively. Be mindful of using these
b2c7354a 448with string equality. C<$FALSE ne $EMPTY>.
59b05e08
JRT
449
450=back
451
452=head1 AUTHOR
453
454Jeffrey Ryan Thalhammer <thaljef@cpan.org>
455
456=head1 COPYRIGHT
457
c3c88e54 458Copyright (c) 2005-2006 Jeffrey Ryan Thalhammer. All rights reserved.
59b05e08
JRT
459
460This program is free software; you can redistribute it and/or modify
461it under the same terms as Perl itself. The full text of this license
462can be found in the LICENSE file included with this module.
dff08b70
JRT
463
464=cut