Login
Importing Perl-Critic-0.13.
[gknop/Perl-Critic.git] / lib / Perl / Critic / Utils.pm
CommitLineData
59b05e08
JRT
1package Perl::Critic::Utils;
2
3use strict;
4use warnings;
5use base 'Exporter';
6
7our $VERSION = '0.13';
8$VERSION = eval $VERSION; ## no critic
9
10#-------------------------------------------------------------------
11# Exported symbols here
12
13our @EXPORT =
14 qw(@BUILTINS @GLOBALS $TRUE
15 $COMMA $DQUOTE $FALSE
16 $COLON $PERIOD &find_keywords
17 $SCOLON $PIPE &is_hash_key
18 $QUOTE $EMPTY &is_method_call
19 $SPACE &parse_arg_list
20);
21
22#---------------------------------------------------------------------------
23
24our $COMMA = q{,};
25our $COLON = q{:};
26our $SCOLON = q{;};
27our $QUOTE = q{'};
28our $DQUOTE = q{"};
29our $PERIOD = q{.};
30our $PIPE = q{|};
31our $SPACE = q{ };
32our $EMPTY = q{};
33our $TRUE = 1;
34our $FALSE = 0;
35
36#---------------------------------------------------------------------------
37our @BUILTINS =
38 qw(abs exp int readdir socket wantarray
39 accept fcntl ioctl readline socketpair warn
40 alarm fileno join readlink sort write
41 atan2 flock keys readpipe splice
42 bind fork kill recv split
43 binmode format last redo sprintf
44 bless formline lc ref sqrt
45 caller getc lcfirst rename srand
46 chdir getgrent length require stat
47 chmod getgrgid link reset study
48 chomp getgrnam listen return sub
49 chop gethostbyaddr local reverse substr
50 chown gethostbyname localtime rewinddir symlink
51 chr gethostent log rindex syscall
52 chroot getlogin lstat rmdir sysopen
53 close getnetbyaddr map scalar sysread
54 closedir getnetbyname mkdir seek sysseek
55 connect getnetent msgctl seekdir system
56 continue getpeername msgget select syswrite
57 cos getpgrp msgrcv semctl tell
58 crypt getppid msgsnd semget telldir
59 dbmclose getpriority next semop tie
60 dbmopen getprotobyname no send tied
61 defined getprotobynumber oct setgrent time
62 delete getprotoent open sethostent times
63 die getpwent opendir setnetent truncate
64 do getpwnam ord setpgrp uc
65 dump getpwuid our setpriority ucfirst
66 each getservbyname pack setprotoent umask
67 endgrent getservbyport package setpwent undef
68 endhostent getservent pipe setservent unlink
69 endnetent getsockname pop setsockopt unpack
70 endprotoent getsockopt pos shift unshift
71 endpwent glob print shmctl untie
72 endservent gmtime printf shmget use
73 eof goto prototype shmread utime
74 eval grep push shmwrite values
75 exec hex quotemeta shutdown vec
76 exists import rand sin wait
77 exit index read sleep waitpid
78);
79
80#---------------------------------------------------------------------------
81
82our @GLOBALS =
83 qw(ACCUMULATOR INPLACE_EDIT
84 BASETIME INPUT_LINE_NUMBER NR
85 CHILD_ERROR INPUT_RECORD_SEPARATOR RS
86 COMPILING LAST_MATCH_END
87 DEBUGGING LAST_REGEXP_CODE_RESULT
88 EFFECTIVE_GROUP_ID EGID LIST_SEPARATOR
89 EFFECTIVE_USER_ID EUID OS_ERROR
90 ENV OSNAME
91 EVAL_ERROR OUTPUT_AUTOFLUSH
92 ERRNO OUTPUT_FIELD_SEPARATOR OFS
93 EXCEPTIONS_BEING_CAUGHT OUTPUT_RECORD_SEPARATOR ORS
94 EXECUTABLE_NAME PERL_VERSION
95 EXTENDED_OS_ERROR PROGRAM_NAME
96 FORMAT_FORMFEED REAL_GROUP_ID GID
97 FORMAT_LINE_BREAK_CHARACTERS REAL_USER_ID UID
98 FORMAT_LINES_LEFT SIG
99 FORMAT_LINES_PER_PAGE SUBSCRIPT_SEPARATOR SUBSEP
100 FORMAT_NAME SYSTEM_FD_MAX
101 FORMAT_PAGE_NUMBER WARNING
102 FORMAT_TOP_NAME PERLDB
103 INC ARGV
104);
105
106#-------------------------------------------------------------------------
107
108sub find_keywords {
109 my ( $doc, $keyword ) = @_;
110 my $nodes_ref = $doc->find('PPI::Token::Word') || return;
111 my @matches = grep { $_ eq $keyword } @{$nodes_ref};
112 return @matches ? \@matches : undef;
113}
114
115sub is_hash_key {
116 my $elem = shift;
117
118 #Check curly-brace style: $hash{foo} = bar;
119 my $parent = $elem->parent() || return;
120 my $grandparent = $parent->parent() || return;
121 return 1 if $grandparent->isa('PPI::Structure::Subscript');
122
123
124 #Check declarative style: %hash = (foo => bar);
125 my $sib = $elem->snext_sibling() || return;
126 return 1 if $sib->isa('PPI::Token::Operator') && $sib eq '=>';
127
128 return 0;
129}
130
131sub is_method_call {
132 my $elem = shift;
133 my $sib = $elem->sprevious_sibling() || return;
134 return $sib->isa('PPI::Token::Operator') && $sib eq q{->};
135}
136
137sub parse_arg_list {
138 my $elem = shift;
139 my $sib = $elem->snext_sibling() || return;
140
141 if ( $sib->isa('PPI::Structure::List') ) {
142
143 #Pull siblings from list
144 my $expr = $sib->schild(0) || return;
145 return _split_nodes_on_comma( $expr->schildren() );
146 }
147 else {
148
149 #Gather up remaining nodes in the statement
150 my $iter = $elem;
151 my @arg_list = ();
152
153 while ($iter = $iter->snext_sibling() ) {
154 last if $iter->isa('PPI::Token::Structure') and $iter eq $SCOLON;
155 push @arg_list, $iter;
156 }
157 return _split_nodes_on_comma( @arg_list );
158 }
159}
160
161sub _split_nodes_on_comma {
162 my @nodes = ();
163 my $i = 0;
164 for my $node (@_) {
165 if ( $node->isa('PPI::Token::Operator') && $node eq $COMMA ) {
166 $i++; #Move forward to next 'node stack'
167 next;
168 }
169
170 #Push onto current 'node stack', or create a new 'stack'
171 if ( defined $nodes[$i] ) {
172 push @{ $nodes[$i] }, $node;
173 }
174 else {
175 $nodes[$i] = [$node];
176 }
177 }
178 return @nodes;
179}
180
1811;
182
183__END__
184
185=head1 NAME
186
187Perl::Critic::Utils - Utility subs and vars for Perl::Critic
188
189=head1 DESCRIPTION
190
191This module has exports several static subs and variables that are
192useful for developing L<Perl::Critic::Policy> subclasses. Unless you
193are writing Policy modules, you probably don't care about this
194package.
195
196=head1 EXPORTED SUBS
197
198=over 8
199
200=item find_keywords( $doc, $keyword );
201
202B<This function is deprecated!> Since version 0.11, every Policy is
203evaluated at each element of the document. So you shouldn't need to
204go looking for a particular keyword. I've left this function in place
205just in case you come across a particular need for it.
206
207Given L<PPI::Document> as C<$doc>, returns a reference to an array
208containing all the L<PPI::Token::Word> elements that match
209C<$keyword>. This can be used to find any built-in function, method
210call, bareword, or reserved keyword. It will not match variables,
211subroutine names, literal strings, numbers, or symbols. If the
212document doesn't contain any matches, returns undef.
213
214=item is_hash_key( $element )
215
216Given a L<PPI::Element>, returns true if the element is a hash key.
217PPI doesn't distinguish between regular barewords (like keywords or
218subroutine calls) and barewords in hash subscripts (which are
219considered literal). So this subroutine is useful if your Policy is
220searching for L<PPI::Token::Word> elements and you want to filter out
221the hash subscript variety. In both of the following examples, 'foo'
222is considered a hash key:
223
224 $hash1{foo} = 1;
225 %hash2 = (foo => 1);
226
227=item is_method_call( $element )
228
229Given a L<PPI::Element> that is presumed to be a function call (which
230is usually a L<PPI::Token::Word>, returns true if the function is a
231method being called on some reference. Baically, it just looks to see
232if the preceding operator is "->". This is usefull for distinguishing
233static from object methods.
234
235=item parse_arg_list( $element )
236
237Given a L<PPI::Element> that is presumed to be a function call (which
238is usually a L<PPI::Token::Word>), splits the argument expressions
239into arrays of tokens. Returns a list containing references to each
240of those arrays. This is useful because parens are optional when
241calling a function, and PPI parses them very differently. So this
242method is a poor-man's parse tree of PPI nodes. It's not bullet-proof
243because it doesn't respect precedence. In general, I don't like the
244way this function works, so don't count on it to be stable (or even
245present).
246
247=back
248
249=head1 EXPORTED VARIABLES
250
251=over 8
252
253=item @BUILTINS
254
255This is a list of all the built-in functions provided by Perl 5.8. I
256imagine this is useful for distinguishing native and non-native
257function calls. In the future, I'm thinking of adding a hash that
258maps each built-in function to the maximal number of arguments that it
259accepts. I think this will help facilitate the lexing the children of
260L<PPI::Expression> objects.
261
262=item @GLOBALS
263
264This is a list of all the magic global variables provided by the
265L<English> module. Also includes commonly-used global like C<%SIG>,
266C<%ENV>, and C<@ARGV>. The list contains only the variable name,
267without the sigil.
268
269=item $COMMA
270
271=item $COLON
272
273=item $SCOLON
274
275=item $QUOTE
276
277=item $DQUOTE
278
279=item $PERIOD
280
281=item $PIPE
282
283=item $EMPTY
284
285These give clear names to commonly-used strings that can be hard to
286read when surrounded by quotes.
287
288=item $TRUE
289
290=item $FALSE
291
292These are simple booleans. 1 and 0 respectively. Be mindful of using these
293with string equality. $FALSE ne $EMPTY.
294
295=back
296
297=head1 AUTHOR
298
299Jeffrey Ryan Thalhammer <thaljef@cpan.org>
300
301=head1 COPYRIGHT
302
303Copyright (c) 2005 Jeffrey Ryan Thalhammer. All rights reserved.
304
305This program is free software; you can redistribute it and/or modify
306it under the same terms as Perl itself. The full text of this license
307can be found in the LICENSE file included with this module.