Commit | Line | Data |
a798dbf2 |
1 | package B::Lint; |
2 | |
1f01d156 |
3 | our $VERSION = '1.01'; |
28b605d8 |
4 | |
a798dbf2 |
5 | =head1 NAME |
6 | |
7 | B::Lint - Perl lint |
8 | |
9 | =head1 SYNOPSIS |
10 | |
11 | perl -MO=Lint[,OPTIONS] foo.pl |
12 | |
13 | =head1 DESCRIPTION |
14 | |
15 | The B::Lint module is equivalent to an extended version of the B<-w> |
16 | option of B<perl>. It is named after the program B<lint> which carries |
17 | out a similar process for C programs. |
18 | |
19 | =head1 OPTIONS AND LINT CHECKS |
20 | |
21 | Option words are separated by commas (not whitespace) and follow the |
22 | usual conventions of compiler backend options. Following any options |
23 | (indicated by a leading B<->) come lint check arguments. Each such |
24 | argument (apart from the special B<all> and B<none> options) is a |
25 | word representing one possible lint check (turning on that check) or |
26 | is B<no-foo> (turning off that check). Before processing the check |
27 | arguments, a standard list of checks is turned on. Later options |
28 | override earlier ones. Available options are: |
29 | |
30 | =over 8 |
31 | |
32 | =item B<context> |
33 | |
34 | Produces a warning whenever an array is used in an implicit scalar |
35 | context. For example, both of the lines |
36 | |
37 | $foo = length(@bar); |
38 | $foo = @bar; |
39 | will elicit a warning. Using an explicit B<scalar()> silences the |
40 | warning. For example, |
41 | |
42 | $foo = scalar(@bar); |
43 | |
44 | =item B<implicit-read> and B<implicit-write> |
45 | |
46 | These options produce a warning whenever an operation implicitly |
47 | reads or (respectively) writes to one of Perl's special variables. |
48 | For example, B<implicit-read> will warn about these: |
49 | |
50 | /foo/; |
51 | |
52 | and B<implicit-write> will warn about these: |
53 | |
54 | s/foo/bar/; |
55 | |
56 | Both B<implicit-read> and B<implicit-write> warn about this: |
57 | |
58 | for (@a) { ... } |
59 | |
40f1df11 |
60 | =item B<bare-subs> |
61 | |
62 | This option warns whenever a bareword is implicitly quoted, but is also |
63 | the name of a subroutine in the current package. Typical mistakes that it will |
64 | trap are: |
65 | |
66 | use constant foo => 'bar'; |
67 | @a = ( foo => 1 ); |
68 | $b{foo} = 2; |
69 | |
70 | Neither of these will do what a naive user would expect. |
71 | |
a798dbf2 |
72 | =item B<dollar-underscore> |
73 | |
74 | This option warns whenever $_ is used either explicitly anywhere or |
75 | as the implicit argument of a B<print> statement. |
76 | |
77 | =item B<private-names> |
78 | |
79 | This option warns on each use of any variable, subroutine or |
80 | method name that lives in a non-current package but begins with |
81 | an underscore ("_"). Warnings aren't issued for the special case |
82 | of the single character name "_" by itself (e.g. $_ and @_). |
83 | |
84 | =item B<undefined-subs> |
85 | |
86 | This option warns whenever an undefined subroutine is invoked. |
87 | This option will only catch explicitly invoked subroutines such |
88 | as C<foo()> and not indirect invocations such as C<&$subref()> |
89 | or C<$obj-E<gt>meth()>. Note that some programs or modules delay |
90 | definition of subs until runtime by means of the AUTOLOAD |
91 | mechanism. |
92 | |
93 | =item B<regexp-variables> |
94 | |
95 | This option warns whenever one of the regexp variables $', $& or |
96 | $' is used. Any occurrence of any of these variables in your |
97 | program can slow your whole program down. See L<perlre> for |
98 | details. |
99 | |
100 | =item B<all> |
101 | |
102 | Turn all warnings on. |
103 | |
104 | =item B<none> |
105 | |
106 | Turn all warnings off. |
107 | |
108 | =back |
109 | |
110 | =head1 NON LINT-CHECK OPTIONS |
111 | |
112 | =over 8 |
113 | |
114 | =item B<-u Package> |
115 | |
116 | Normally, Lint only checks the main code of the program together |
117 | with all subs defined in package main. The B<-u> option lets you |
118 | include other package names whose subs are then checked by Lint. |
119 | |
120 | =back |
121 | |
122 | =head1 BUGS |
123 | |
124 | This is only a very preliminary version. |
125 | |
94011a57 |
126 | This module doesn't work correctly on thread-enabled perls. |
127 | |
a798dbf2 |
128 | =head1 AUTHOR |
129 | |
130 | Malcolm Beattie, mbeattie@sable.ox.ac.uk. |
131 | |
132 | =cut |
133 | |
134 | use strict; |
b0a2b4f5 |
135 | use B qw(walkoptree_slow main_root walksymtable svref_2object parents |
40f1df11 |
136 | OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK |
4c1f658f |
137 | ); |
a798dbf2 |
138 | |
139 | my $file = "unknown"; # shadows current filename |
140 | my $line = 0; # shadows current line number |
141 | my $curstash = "main"; # shadows current stash |
142 | |
143 | # Lint checks |
144 | my %check; |
145 | my %implies_ok_context; |
146 | BEGIN { |
147 | map($implies_ok_context{$_}++, |
3f872cb9 |
148 | qw(scalar av2arylen aelem aslice helem hslice |
149 | keys values hslice defined undef delete)); |
a798dbf2 |
150 | } |
151 | |
152 | # Lint checks turned on by default |
153 | my @default_checks = qw(context); |
154 | |
155 | my %valid_check; |
156 | # All valid checks |
157 | BEGIN { |
158 | map($valid_check{$_}++, |
159 | qw(context implicit_read implicit_write dollar_underscore |
40f1df11 |
160 | private_names bare_subs undefined_subs regexp_variables)); |
a798dbf2 |
161 | } |
162 | |
163 | # Debugging options |
164 | my ($debug_op); |
165 | |
166 | my %done_cv; # used to mark which subs have already been linted |
167 | my @extra_packages; # Lint checks mainline code and all subs which are |
168 | # in main:: or in one of these packages. |
169 | |
170 | sub warning { |
171 | my $format = (@_ < 2) ? "%s" : shift; |
172 | warn sprintf("$format at %s line %d\n", @_, $file, $line); |
173 | } |
174 | |
175 | # This gimme can't cope with context that's only determined |
176 | # at runtime via dowantarray(). |
177 | sub gimme { |
178 | my $op = shift; |
179 | my $flags = $op->flags; |
4c1f658f |
180 | if ($flags & OPf_WANT) { |
94011a57 |
181 | return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0); |
a798dbf2 |
182 | } |
183 | return undef; |
184 | } |
185 | |
186 | sub B::OP::lint {} |
187 | |
188 | sub B::COP::lint { |
189 | my $op = shift; |
3f872cb9 |
190 | if ($op->name eq "nextstate") { |
57843af0 |
191 | $file = $op->file; |
a798dbf2 |
192 | $line = $op->line; |
193 | $curstash = $op->stash->NAME; |
194 | } |
195 | } |
196 | |
197 | sub B::UNOP::lint { |
198 | my $op = shift; |
3f872cb9 |
199 | my $opname = $op->name; |
200 | if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) { |
a798dbf2 |
201 | my $parent = parents->[0]; |
3f872cb9 |
202 | my $pname = $parent->name; |
a798dbf2 |
203 | return if gimme($op) || $implies_ok_context{$pname}; |
204 | # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" |
205 | # null out the parent so we have to check for a parent of pp_null and |
206 | # a grandparent of pp_enteriter or pp_delete |
3f872cb9 |
207 | if ($pname eq "null") { |
208 | my $gpname = parents->[1]->name; |
209 | return if $gpname eq "enteriter" || $gpname eq "delete"; |
a798dbf2 |
210 | } |
211 | warning("Implicit scalar context for %s in %s", |
3f872cb9 |
212 | $opname eq "rv2av" ? "array" : "hash", $parent->desc); |
a798dbf2 |
213 | } |
3f872cb9 |
214 | if ($check{private_names} && $opname eq "method") { |
a798dbf2 |
215 | my $methop = $op->first; |
3f872cb9 |
216 | if ($methop->name eq "const") { |
a798dbf2 |
217 | my $method = $methop->sv->PV; |
218 | if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { |
219 | warning("Illegal reference to private method name $method"); |
220 | } |
221 | } |
222 | } |
223 | } |
224 | |
225 | sub B::PMOP::lint { |
226 | my $op = shift; |
227 | if ($check{implicit_read}) { |
3f872cb9 |
228 | if ($op->name eq "match" && !($op->flags & OPf_STACKED)) { |
a798dbf2 |
229 | warning('Implicit match on $_'); |
230 | } |
231 | } |
232 | if ($check{implicit_write}) { |
3f872cb9 |
233 | if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) { |
a798dbf2 |
234 | warning('Implicit substitution on $_'); |
235 | } |
236 | } |
237 | } |
238 | |
239 | sub B::LOOP::lint { |
240 | my $op = shift; |
241 | if ($check{implicit_read} || $check{implicit_write}) { |
3f872cb9 |
242 | if ($op->name eq "enteriter") { |
a798dbf2 |
243 | my $last = $op->last; |
3f872cb9 |
244 | if ($last->name eq "gv" && $last->gv->NAME eq "_") { |
a798dbf2 |
245 | warning('Implicit use of $_ in foreach'); |
246 | } |
247 | } |
248 | } |
249 | } |
250 | |
7934575e |
251 | sub B::SVOP::lint { |
a798dbf2 |
252 | my $op = shift; |
40f1df11 |
253 | if ( $check{bare_subs} && $op->name eq 'const' |
254 | && $op->private & 64 ) # OPpCONST_BARE = 64 in op.h |
255 | { |
256 | my $sv = $op->sv; |
257 | if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) { |
258 | warning "Bare sub name '" . $sv->PV . "' interpreted as string"; |
259 | } |
260 | } |
3f872cb9 |
261 | if ($check{dollar_underscore} && $op->name eq "gvsv" |
a798dbf2 |
262 | && $op->gv->NAME eq "_") |
263 | { |
264 | warning('Use of $_'); |
265 | } |
266 | if ($check{private_names}) { |
3f872cb9 |
267 | my $opname = $op->name; |
4f25aa18 |
268 | if ($opname eq "gv" || $opname eq "gvsv") { |
7934575e |
269 | my $gv = $op->gv; |
270 | if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) { |
271 | warning('Illegal reference to private name %s', $gv->NAME); |
272 | } |
bfecbe02 |
273 | } elsif ($opname eq "method_named") { |
274 | my $method = $op->gv->PV; |
275 | if ($method =~ /^_./) { |
276 | warning("Illegal reference to private method name $method"); |
277 | } |
a798dbf2 |
278 | } |
279 | } |
280 | if ($check{undefined_subs}) { |
3f872cb9 |
281 | if ($op->name eq "gv" |
282 | && $op->next->name eq "entersub") |
283 | { |
a798dbf2 |
284 | my $gv = $op->gv; |
285 | my $subname = $gv->STASH->NAME . "::" . $gv->NAME; |
286 | no strict 'refs'; |
287 | if (!defined(&$subname)) { |
288 | $subname =~ s/^main:://; |
289 | warning('Undefined subroutine %s called', $subname); |
290 | } |
291 | } |
292 | } |
3f872cb9 |
293 | if ($check{regexp_variables} && $op->name eq "gvsv") { |
a798dbf2 |
294 | my $name = $op->gv->NAME; |
295 | if ($name =~ /^[&'`]$/) { |
296 | warning('Use of regexp variable $%s', $name); |
297 | } |
298 | } |
299 | } |
300 | |
301 | sub B::GV::lintcv { |
302 | my $gv = shift; |
303 | my $cv = $gv->CV; |
304 | #warn sprintf("lintcv: %s::%s (done=%d)\n", |
305 | # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug |
306 | return if !$$cv || $done_cv{$$cv}++; |
307 | my $root = $cv->ROOT; |
308 | #warn " root = $root (0x$$root)\n";#debug |
b0a2b4f5 |
309 | walkoptree_slow($root, "lint") if $$root; |
a798dbf2 |
310 | } |
311 | |
312 | sub do_lint { |
313 | my %search_pack; |
b0a2b4f5 |
314 | walkoptree_slow(main_root, "lint") if ${main_root()}; |
a798dbf2 |
315 | |
316 | # Now do subs in main |
317 | no strict qw(vars refs); |
a798dbf2 |
318 | local(*glob); |
0091380b |
319 | for my $sym (keys %main::) { |
320 | next if $sym =~ /::$/; |
321 | *glob = $main::{$sym}; |
322 | svref_2object(\*glob)->EGV->lintcv; |
a798dbf2 |
323 | } |
324 | |
325 | # Now do subs in non-main packages given by -u options |
326 | map { $search_pack{$_} = 1 } @extra_packages; |
327 | walksymtable(\%{"main::"}, "lintcv", sub { |
328 | my $package = shift; |
329 | $package =~ s/::$//; |
330 | #warn "Considering $package\n";#debug |
331 | return exists $search_pack{$package}; |
332 | }); |
333 | } |
334 | |
335 | sub compile { |
336 | my @options = @_; |
337 | my ($option, $opt, $arg); |
338 | # Turn on default lint checks |
339 | for $opt (@default_checks) { |
340 | $check{$opt} = 1; |
341 | } |
342 | OPTION: |
343 | while ($option = shift @options) { |
344 | if ($option =~ /^-(.)(.*)/) { |
345 | $opt = $1; |
346 | $arg = $2; |
347 | } else { |
348 | unshift @options, $option; |
349 | last OPTION; |
350 | } |
351 | if ($opt eq "-" && $arg eq "-") { |
352 | shift @options; |
353 | last OPTION; |
354 | } elsif ($opt eq "D") { |
355 | $arg ||= shift @options; |
356 | foreach $arg (split(//, $arg)) { |
357 | if ($arg eq "o") { |
358 | B->debug(1); |
359 | } elsif ($arg eq "O") { |
360 | $debug_op = 1; |
361 | } |
362 | } |
363 | } elsif ($opt eq "u") { |
364 | $arg ||= shift @options; |
365 | push(@extra_packages, $arg); |
366 | } |
367 | } |
368 | foreach $opt (@default_checks, @options) { |
369 | $opt =~ tr/-/_/; |
370 | if ($opt eq "all") { |
371 | %check = %valid_check; |
372 | } |
373 | elsif ($opt eq "none") { |
374 | %check = (); |
375 | } |
376 | else { |
7f0faf35 |
377 | if ($opt =~ s/^no_//) { |
a798dbf2 |
378 | $check{$opt} = 0; |
379 | } |
380 | else { |
381 | $check{$opt} = 1; |
382 | } |
383 | warn "No such check: $opt\n" unless defined $valid_check{$opt}; |
384 | } |
385 | } |
386 | # Remaining arguments are things to check |
387 | |
388 | return \&do_lint; |
389 | } |
390 | |
391 | 1; |