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