Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package B::Lint; |
2 | ||
3 | our $VERSION = '1.01'; | |
4 | ||
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 | ||
60 | =item B<dollar-underscore> | |
61 | ||
62 | This option warns whenever $_ is used either explicitly anywhere or | |
63 | as the implicit argument of a B<print> statement. | |
64 | ||
65 | =item B<private-names> | |
66 | ||
67 | This option warns on each use of any variable, subroutine or | |
68 | method name that lives in a non-current package but begins with | |
69 | an underscore ("_"). Warnings aren't issued for the special case | |
70 | of the single character name "_" by itself (e.g. $_ and @_). | |
71 | ||
72 | =item B<undefined-subs> | |
73 | ||
74 | This option warns whenever an undefined subroutine is invoked. | |
75 | This option will only catch explicitly invoked subroutines such | |
76 | as C<foo()> and not indirect invocations such as C<&$subref()> | |
77 | or C<$obj-E<gt>meth()>. Note that some programs or modules delay | |
78 | definition of subs until runtime by means of the AUTOLOAD | |
79 | mechanism. | |
80 | ||
81 | =item B<regexp-variables> | |
82 | ||
83 | This option warns whenever one of the regexp variables $', $& or | |
84 | $' is used. Any occurrence of any of these variables in your | |
85 | program can slow your whole program down. See L<perlre> for | |
86 | details. | |
87 | ||
88 | =item B<all> | |
89 | ||
90 | Turn all warnings on. | |
91 | ||
92 | =item B<none> | |
93 | ||
94 | Turn all warnings off. | |
95 | ||
96 | =back | |
97 | ||
98 | =head1 NON LINT-CHECK OPTIONS | |
99 | ||
100 | =over 8 | |
101 | ||
102 | =item B<-u Package> | |
103 | ||
104 | Normally, Lint only checks the main code of the program together | |
105 | with all subs defined in package main. The B<-u> option lets you | |
106 | include other package names whose subs are then checked by Lint. | |
107 | ||
108 | =back | |
109 | ||
110 | =head1 BUGS | |
111 | ||
112 | This is only a very preliminary version. | |
113 | ||
114 | This module doesn't work correctly on thread-enabled perls. | |
115 | ||
116 | =head1 AUTHOR | |
117 | ||
118 | Malcolm Beattie, mbeattie@sable.ox.ac.uk. | |
119 | ||
120 | =cut | |
121 | ||
122 | use strict; | |
123 | use B qw(walkoptree_slow main_root walksymtable svref_2object parents | |
124 | OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY | |
125 | ); | |
126 | ||
127 | my $file = "unknown"; # shadows current filename | |
128 | my $line = 0; # shadows current line number | |
129 | my $curstash = "main"; # shadows current stash | |
130 | ||
131 | # Lint checks | |
132 | my %check; | |
133 | my %implies_ok_context; | |
134 | BEGIN { | |
135 | map($implies_ok_context{$_}++, | |
136 | qw(scalar av2arylen aelem aslice helem hslice | |
137 | keys values hslice defined undef delete)); | |
138 | } | |
139 | ||
140 | # Lint checks turned on by default | |
141 | my @default_checks = qw(context); | |
142 | ||
143 | my %valid_check; | |
144 | # All valid checks | |
145 | BEGIN { | |
146 | map($valid_check{$_}++, | |
147 | qw(context implicit_read implicit_write dollar_underscore | |
148 | private_names undefined_subs regexp_variables)); | |
149 | } | |
150 | ||
151 | # Debugging options | |
152 | my ($debug_op); | |
153 | ||
154 | my %done_cv; # used to mark which subs have already been linted | |
155 | my @extra_packages; # Lint checks mainline code and all subs which are | |
156 | # in main:: or in one of these packages. | |
157 | ||
158 | sub warning { | |
159 | my $format = (@_ < 2) ? "%s" : shift; | |
160 | warn sprintf("$format at %s line %d\n", @_, $file, $line); | |
161 | } | |
162 | ||
163 | # This gimme can't cope with context that's only determined | |
164 | # at runtime via dowantarray(). | |
165 | sub gimme { | |
166 | my $op = shift; | |
167 | my $flags = $op->flags; | |
168 | if ($flags & OPf_WANT) { | |
169 | return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0); | |
170 | } | |
171 | return undef; | |
172 | } | |
173 | ||
174 | sub B::OP::lint {} | |
175 | ||
176 | sub B::COP::lint { | |
177 | my $op = shift; | |
178 | if ($op->name eq "nextstate") { | |
179 | $file = $op->file; | |
180 | $line = $op->line; | |
181 | $curstash = $op->stash->NAME; | |
182 | } | |
183 | } | |
184 | ||
185 | sub B::UNOP::lint { | |
186 | my $op = shift; | |
187 | my $opname = $op->name; | |
188 | if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) { | |
189 | my $parent = parents->[0]; | |
190 | my $pname = $parent->name; | |
191 | return if gimme($op) || $implies_ok_context{$pname}; | |
192 | # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" | |
193 | # null out the parent so we have to check for a parent of pp_null and | |
194 | # a grandparent of pp_enteriter or pp_delete | |
195 | if ($pname eq "null") { | |
196 | my $gpname = parents->[1]->name; | |
197 | return if $gpname eq "enteriter" || $gpname eq "delete"; | |
198 | } | |
199 | warning("Implicit scalar context for %s in %s", | |
200 | $opname eq "rv2av" ? "array" : "hash", $parent->desc); | |
201 | } | |
202 | if ($check{private_names} && $opname eq "method") { | |
203 | my $methop = $op->first; | |
204 | if ($methop->name eq "const") { | |
205 | my $method = $methop->sv->PV; | |
206 | if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { | |
207 | warning("Illegal reference to private method name $method"); | |
208 | } | |
209 | } | |
210 | } | |
211 | } | |
212 | ||
213 | sub B::PMOP::lint { | |
214 | my $op = shift; | |
215 | if ($check{implicit_read}) { | |
216 | if ($op->name eq "match" && !($op->flags & OPf_STACKED)) { | |
217 | warning('Implicit match on $_'); | |
218 | } | |
219 | } | |
220 | if ($check{implicit_write}) { | |
221 | if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) { | |
222 | warning('Implicit substitution on $_'); | |
223 | } | |
224 | } | |
225 | } | |
226 | ||
227 | sub B::LOOP::lint { | |
228 | my $op = shift; | |
229 | if ($check{implicit_read} || $check{implicit_write}) { | |
230 | if ($op->name eq "enteriter") { | |
231 | my $last = $op->last; | |
232 | if ($last->name eq "gv" && $last->gv->NAME eq "_") { | |
233 | warning('Implicit use of $_ in foreach'); | |
234 | } | |
235 | } | |
236 | } | |
237 | } | |
238 | ||
239 | sub B::SVOP::lint { | |
240 | my $op = shift; | |
241 | if ($check{dollar_underscore} && $op->name eq "gvsv" | |
242 | && $op->gv->NAME eq "_") | |
243 | { | |
244 | warning('Use of $_'); | |
245 | } | |
246 | if ($check{private_names}) { | |
247 | my $opname = $op->name; | |
248 | if ($opname eq "gv" || $opname eq "gvsv") { | |
249 | my $gv = $op->gv; | |
250 | if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) { | |
251 | warning('Illegal reference to private name %s', $gv->NAME); | |
252 | } | |
253 | } elsif ($opname eq "method_named") { | |
254 | my $method = $op->gv->PV; | |
255 | if ($method =~ /^_./) { | |
256 | warning("Illegal reference to private method name $method"); | |
257 | } | |
258 | } | |
259 | } | |
260 | if ($check{undefined_subs}) { | |
261 | if ($op->name eq "gv" | |
262 | && $op->next->name eq "entersub") | |
263 | { | |
264 | my $gv = $op->gv; | |
265 | my $subname = $gv->STASH->NAME . "::" . $gv->NAME; | |
266 | no strict 'refs'; | |
267 | if (!defined(&$subname)) { | |
268 | $subname =~ s/^main:://; | |
269 | warning('Undefined subroutine %s called', $subname); | |
270 | } | |
271 | } | |
272 | } | |
273 | if ($check{regexp_variables} && $op->name eq "gvsv") { | |
274 | my $name = $op->gv->NAME; | |
275 | if ($name =~ /^[&'`]$/) { | |
276 | warning('Use of regexp variable $%s', $name); | |
277 | } | |
278 | } | |
279 | } | |
280 | ||
281 | sub B::GV::lintcv { | |
282 | my $gv = shift; | |
283 | my $cv = $gv->CV; | |
284 | #warn sprintf("lintcv: %s::%s (done=%d)\n", | |
285 | # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug | |
286 | return if !$$cv || $done_cv{$$cv}++; | |
287 | my $root = $cv->ROOT; | |
288 | #warn " root = $root (0x$$root)\n";#debug | |
289 | walkoptree_slow($root, "lint") if $$root; | |
290 | } | |
291 | ||
292 | sub do_lint { | |
293 | my %search_pack; | |
294 | walkoptree_slow(main_root, "lint") if ${main_root()}; | |
295 | ||
296 | # Now do subs in main | |
297 | no strict qw(vars refs); | |
298 | local(*glob); | |
299 | for my $sym (keys %main::) { | |
300 | next if $sym =~ /::$/; | |
301 | *glob = $main::{$sym}; | |
302 | svref_2object(\*glob)->EGV->lintcv; | |
303 | } | |
304 | ||
305 | # Now do subs in non-main packages given by -u options | |
306 | map { $search_pack{$_} = 1 } @extra_packages; | |
307 | walksymtable(\%{"main::"}, "lintcv", sub { | |
308 | my $package = shift; | |
309 | $package =~ s/::$//; | |
310 | #warn "Considering $package\n";#debug | |
311 | return exists $search_pack{$package}; | |
312 | }); | |
313 | } | |
314 | ||
315 | sub compile { | |
316 | my @options = @_; | |
317 | my ($option, $opt, $arg); | |
318 | # Turn on default lint checks | |
319 | for $opt (@default_checks) { | |
320 | $check{$opt} = 1; | |
321 | } | |
322 | OPTION: | |
323 | while ($option = shift @options) { | |
324 | if ($option =~ /^-(.)(.*)/) { | |
325 | $opt = $1; | |
326 | $arg = $2; | |
327 | } else { | |
328 | unshift @options, $option; | |
329 | last OPTION; | |
330 | } | |
331 | if ($opt eq "-" && $arg eq "-") { | |
332 | shift @options; | |
333 | last OPTION; | |
334 | } elsif ($opt eq "D") { | |
335 | $arg ||= shift @options; | |
336 | foreach $arg (split(//, $arg)) { | |
337 | if ($arg eq "o") { | |
338 | B->debug(1); | |
339 | } elsif ($arg eq "O") { | |
340 | $debug_op = 1; | |
341 | } | |
342 | } | |
343 | } elsif ($opt eq "u") { | |
344 | $arg ||= shift @options; | |
345 | push(@extra_packages, $arg); | |
346 | } | |
347 | } | |
348 | foreach $opt (@default_checks, @options) { | |
349 | $opt =~ tr/-/_/; | |
350 | if ($opt eq "all") { | |
351 | %check = %valid_check; | |
352 | } | |
353 | elsif ($opt eq "none") { | |
354 | %check = (); | |
355 | } | |
356 | else { | |
357 | if ($opt =~ s/^no_//) { | |
358 | $check{$opt} = 0; | |
359 | } | |
360 | else { | |
361 | $check{$opt} = 1; | |
362 | } | |
363 | warn "No such check: $opt\n" unless defined $valid_check{$opt}; | |
364 | } | |
365 | } | |
366 | # Remaining arguments are things to check | |
367 | ||
368 | return \&do_lint; | |
369 | } | |
370 | ||
371 | 1; |