This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move lib/B/... and lib/[BO].pm over to where they should be,
[perl5.git] / ext / B / B / Lint.pm
CommitLineData
a798dbf2
MB
1package B::Lint;
2
3=head1 NAME
4
5B::Lint - Perl lint
6
7=head1 SYNOPSIS
8
9perl -MO=Lint[,OPTIONS] foo.pl
10
11=head1 DESCRIPTION
12
13The B::Lint module is equivalent to an extended version of the B<-w>
14option of B<perl>. It is named after the program B<lint> which carries
15out a similar process for C programs.
16
17=head1 OPTIONS AND LINT CHECKS
18
19Option words are separated by commas (not whitespace) and follow the
20usual conventions of compiler backend options. Following any options
21(indicated by a leading B<->) come lint check arguments. Each such
22argument (apart from the special B<all> and B<none> options) is a
23word representing one possible lint check (turning on that check) or
24is B<no-foo> (turning off that check). Before processing the check
25arguments, a standard list of checks is turned on. Later options
26override earlier ones. Available options are:
27
28=over 8
29
30=item B<context>
31
32Produces a warning whenever an array is used in an implicit scalar
33context. For example, both of the lines
34
35 $foo = length(@bar);
36 $foo = @bar;
37will elicit a warning. Using an explicit B<scalar()> silences the
38warning. For example,
39
40 $foo = scalar(@bar);
41
42=item B<implicit-read> and B<implicit-write>
43
44These options produce a warning whenever an operation implicitly
45reads or (respectively) writes to one of Perl's special variables.
46For example, B<implicit-read> will warn about these:
47
48 /foo/;
49
50and B<implicit-write> will warn about these:
51
52 s/foo/bar/;
53
54Both B<implicit-read> and B<implicit-write> warn about this:
55
56 for (@a) { ... }
57
58=item B<dollar-underscore>
59
60This option warns whenever $_ is used either explicitly anywhere or
61as the implicit argument of a B<print> statement.
62
63=item B<private-names>
64
65This option warns on each use of any variable, subroutine or
66method name that lives in a non-current package but begins with
67an underscore ("_"). Warnings aren't issued for the special case
68of the single character name "_" by itself (e.g. $_ and @_).
69
70=item B<undefined-subs>
71
72This option warns whenever an undefined subroutine is invoked.
73This option will only catch explicitly invoked subroutines such
74as C<foo()> and not indirect invocations such as C<&$subref()>
75or C<$obj-E<gt>meth()>. Note that some programs or modules delay
76definition of subs until runtime by means of the AUTOLOAD
77mechanism.
78
79=item B<regexp-variables>
80
81This option warns whenever one of the regexp variables $', $& or
82$' is used. Any occurrence of any of these variables in your
83program can slow your whole program down. See L<perlre> for
84details.
85
86=item B<all>
87
88Turn all warnings on.
89
90=item B<none>
91
92Turn all warnings off.
93
94=back
95
96=head1 NON LINT-CHECK OPTIONS
97
98=over 8
99
100=item B<-u Package>
101
102Normally, Lint only checks the main code of the program together
103with all subs defined in package main. The B<-u> option lets you
104include other package names whose subs are then checked by Lint.
105
106=back
107
108=head1 BUGS
109
110This is only a very preliminary version.
111
112=head1 AUTHOR
113
114Malcolm Beattie, mbeattie@sable.ox.ac.uk.
115
116=cut
117
118use strict;
119use B qw(walkoptree_slow main_root walksymtable svref_2object parents);
120
121# Constants (should probably be elsewhere)
122sub G_ARRAY () { 1 }
123sub OPf_LIST () { 1 }
124sub OPf_KNOW () { 2 }
125sub OPf_STACKED () { 64 }
126
127my $file = "unknown"; # shadows current filename
128my $line = 0; # shadows current line number
129my $curstash = "main"; # shadows current stash
130
131# Lint checks
132my %check;
133my %implies_ok_context;
134BEGIN {
135 map($implies_ok_context{$_}++,
136 qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice
137 pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete));
138}
139
140# Lint checks turned on by default
141my @default_checks = qw(context);
142
143my %valid_check;
144# All valid checks
145BEGIN {
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
152my ($debug_op);
153
154my %done_cv; # used to mark which subs have already been linted
155my @extra_packages; # Lint checks mainline code and all subs which are
156 # in main:: or in one of these packages.
157
158sub 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().
165sub gimme {
166 my $op = shift;
167 my $flags = $op->flags;
168 if ($flags & OPf_KNOW) {
169 return(($flags & OPf_LIST) ? 1 : 0);
170 }
171 return undef;
172}
173
174sub B::OP::lint {}
175
176sub B::COP::lint {
177 my $op = shift;
178 if ($op->ppaddr eq "pp_nextstate") {
179 $file = $op->filegv->SV->PV;
180 $line = $op->line;
181 $curstash = $op->stash->NAME;
182 }
183}
184
185sub B::UNOP::lint {
186 my $op = shift;
187 my $ppaddr = $op->ppaddr;
188 if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) {
189 my $parent = parents->[0];
190 my $pname = $parent->ppaddr;
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 "pp_null") {
196 my $gpname = parents->[1]->ppaddr;
197 return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete";
198 }
199 warning("Implicit scalar context for %s in %s",
200 $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc);
201 }
202 if ($check{private_names} && $ppaddr eq "pp_method") {
203 my $methop = $op->first;
204 if ($methop->ppaddr eq "pp_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
213sub B::PMOP::lint {
214 my $op = shift;
215 if ($check{implicit_read}) {
216 my $ppaddr = $op->ppaddr;
217 if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) {
218 warning('Implicit match on $_');
219 }
220 }
221 if ($check{implicit_write}) {
222 my $ppaddr = $op->ppaddr;
223 if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) {
224 warning('Implicit substitution on $_');
225 }
226 }
227}
228
229sub B::LOOP::lint {
230 my $op = shift;
231 if ($check{implicit_read} || $check{implicit_write}) {
232 my $ppaddr = $op->ppaddr;
233 if ($ppaddr eq "pp_enteriter") {
234 my $last = $op->last;
235 if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") {
236 warning('Implicit use of $_ in foreach');
237 }
238 }
239 }
240}
241
242sub B::GVOP::lint {
243 my $op = shift;
244 if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv"
245 && $op->gv->NAME eq "_")
246 {
247 warning('Use of $_');
248 }
249 if ($check{private_names}) {
250 my $ppaddr = $op->ppaddr;
251 my $gv = $op->gv;
252 if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv")
253 && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash)
254 {
255 warning('Illegal reference to private name %s', $gv->NAME);
256 }
257 }
258 if ($check{undefined_subs}) {
259 if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") {
260 my $gv = $op->gv;
261 my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
262 no strict 'refs';
263 if (!defined(&$subname)) {
264 $subname =~ s/^main:://;
265 warning('Undefined subroutine %s called', $subname);
266 }
267 }
268 }
269 if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") {
270 my $name = $op->gv->NAME;
271 if ($name =~ /^[&'`]$/) {
272 warning('Use of regexp variable $%s', $name);
273 }
274 }
275}
276
277sub B::GV::lintcv {
278 my $gv = shift;
279 my $cv = $gv->CV;
280 #warn sprintf("lintcv: %s::%s (done=%d)\n",
281 # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
282 return if !$$cv || $done_cv{$$cv}++;
283 my $root = $cv->ROOT;
284 #warn " root = $root (0x$$root)\n";#debug
285 walkoptree_slow($root, "lint") if $$root;
286}
287
288sub do_lint {
289 my %search_pack;
290 walkoptree_slow(main_root, "lint") if ${main_root()};
291
292 # Now do subs in main
293 no strict qw(vars refs);
294 my $sym;
295 local(*glob);
296 while (($sym, *glob) = each %{"main::"}) {
297 #warn "Trying $sym\n";#debug
298 svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/;
299 }
300
301 # Now do subs in non-main packages given by -u options
302 map { $search_pack{$_} = 1 } @extra_packages;
303 walksymtable(\%{"main::"}, "lintcv", sub {
304 my $package = shift;
305 $package =~ s/::$//;
306 #warn "Considering $package\n";#debug
307 return exists $search_pack{$package};
308 });
309}
310
311sub compile {
312 my @options = @_;
313 my ($option, $opt, $arg);
314 # Turn on default lint checks
315 for $opt (@default_checks) {
316 $check{$opt} = 1;
317 }
318 OPTION:
319 while ($option = shift @options) {
320 if ($option =~ /^-(.)(.*)/) {
321 $opt = $1;
322 $arg = $2;
323 } else {
324 unshift @options, $option;
325 last OPTION;
326 }
327 if ($opt eq "-" && $arg eq "-") {
328 shift @options;
329 last OPTION;
330 } elsif ($opt eq "D") {
331 $arg ||= shift @options;
332 foreach $arg (split(//, $arg)) {
333 if ($arg eq "o") {
334 B->debug(1);
335 } elsif ($arg eq "O") {
336 $debug_op = 1;
337 }
338 }
339 } elsif ($opt eq "u") {
340 $arg ||= shift @options;
341 push(@extra_packages, $arg);
342 }
343 }
344 foreach $opt (@default_checks, @options) {
345 $opt =~ tr/-/_/;
346 if ($opt eq "all") {
347 %check = %valid_check;
348 }
349 elsif ($opt eq "none") {
350 %check = ();
351 }
352 else {
353 if ($opt =~ s/^no-//) {
354 $check{$opt} = 0;
355 }
356 else {
357 $check{$opt} = 1;
358 }
359 warn "No such check: $opt\n" unless defined $valid_check{$opt};
360 }
361 }
362 # Remaining arguments are things to check
363
364 return \&do_lint;
365}
366
3671;