This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix a remaining B::Lint bug.
[perl5.git] / ext / B / B / Lint.pm
CommitLineData
a798dbf2
MB
1package B::Lint;
2
1f01d156 3our $VERSION = '1.01';
28b605d8 4
a798dbf2
MB
5=head1 NAME
6
7B::Lint - Perl lint
8
9=head1 SYNOPSIS
10
11perl -MO=Lint[,OPTIONS] foo.pl
12
13=head1 DESCRIPTION
14
15The B::Lint module is equivalent to an extended version of the B<-w>
16option of B<perl>. It is named after the program B<lint> which carries
17out a similar process for C programs.
18
19=head1 OPTIONS AND LINT CHECKS
20
21Option words are separated by commas (not whitespace) and follow the
22usual conventions of compiler backend options. Following any options
23(indicated by a leading B<->) come lint check arguments. Each such
24argument (apart from the special B<all> and B<none> options) is a
25word representing one possible lint check (turning on that check) or
26is B<no-foo> (turning off that check). Before processing the check
27arguments, a standard list of checks is turned on. Later options
28override earlier ones. Available options are:
29
30=over 8
31
32=item B<context>
33
34Produces a warning whenever an array is used in an implicit scalar
35context. For example, both of the lines
36
37 $foo = length(@bar);
38 $foo = @bar;
39will elicit a warning. Using an explicit B<scalar()> silences the
40warning. For example,
41
42 $foo = scalar(@bar);
43
44=item B<implicit-read> and B<implicit-write>
45
46These options produce a warning whenever an operation implicitly
47reads or (respectively) writes to one of Perl's special variables.
48For example, B<implicit-read> will warn about these:
49
50 /foo/;
51
52and B<implicit-write> will warn about these:
53
54 s/foo/bar/;
55
56Both B<implicit-read> and B<implicit-write> warn about this:
57
58 for (@a) { ... }
59
60=item B<dollar-underscore>
61
62This option warns whenever $_ is used either explicitly anywhere or
63as the implicit argument of a B<print> statement.
64
65=item B<private-names>
66
67This option warns on each use of any variable, subroutine or
68method name that lives in a non-current package but begins with
69an underscore ("_"). Warnings aren't issued for the special case
70of the single character name "_" by itself (e.g. $_ and @_).
71
72=item B<undefined-subs>
73
74This option warns whenever an undefined subroutine is invoked.
75This option will only catch explicitly invoked subroutines such
76as C<foo()> and not indirect invocations such as C<&$subref()>
77or C<$obj-E<gt>meth()>. Note that some programs or modules delay
78definition of subs until runtime by means of the AUTOLOAD
79mechanism.
80
81=item B<regexp-variables>
82
83This option warns whenever one of the regexp variables $', $& or
84$' is used. Any occurrence of any of these variables in your
85program can slow your whole program down. See L<perlre> for
86details.
87
88=item B<all>
89
90Turn all warnings on.
91
92=item B<none>
93
94Turn all warnings off.
95
96=back
97
98=head1 NON LINT-CHECK OPTIONS
99
100=over 8
101
102=item B<-u Package>
103
104Normally, Lint only checks the main code of the program together
105with all subs defined in package main. The B<-u> option lets you
106include other package names whose subs are then checked by Lint.
107
108=back
109
110=head1 BUGS
111
112This is only a very preliminary version.
113
94011a57
JH
114This module doesn't work correctly on thread-enabled perls.
115
a798dbf2
MB
116=head1 AUTHOR
117
118Malcolm Beattie, mbeattie@sable.ox.ac.uk.
119
120=cut
121
122use strict;
b0a2b4f5 123use B qw(walkoptree_slow main_root walksymtable svref_2object parents
4c1f658f
NIS
124 OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
125 );
a798dbf2
MB
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{$_}++,
3f872cb9
GS
136 qw(scalar av2arylen aelem aslice helem hslice
137 keys values hslice defined undef delete));
a798dbf2
MB
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;
4c1f658f 168 if ($flags & OPf_WANT) {
94011a57 169 return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
a798dbf2
MB
170 }
171 return undef;
172}
173
174sub B::OP::lint {}
175
176sub B::COP::lint {
177 my $op = shift;
3f872cb9 178 if ($op->name eq "nextstate") {
57843af0 179 $file = $op->file;
a798dbf2
MB
180 $line = $op->line;
181 $curstash = $op->stash->NAME;
182 }
183}
184
185sub B::UNOP::lint {
186 my $op = shift;
3f872cb9
GS
187 my $opname = $op->name;
188 if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
a798dbf2 189 my $parent = parents->[0];
3f872cb9 190 my $pname = $parent->name;
a798dbf2
MB
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
3f872cb9
GS
195 if ($pname eq "null") {
196 my $gpname = parents->[1]->name;
197 return if $gpname eq "enteriter" || $gpname eq "delete";
a798dbf2
MB
198 }
199 warning("Implicit scalar context for %s in %s",
3f872cb9 200 $opname eq "rv2av" ? "array" : "hash", $parent->desc);
a798dbf2 201 }
3f872cb9 202 if ($check{private_names} && $opname eq "method") {
a798dbf2 203 my $methop = $op->first;
3f872cb9 204 if ($methop->name eq "const") {
a798dbf2
MB
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}) {
3f872cb9 216 if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
a798dbf2
MB
217 warning('Implicit match on $_');
218 }
219 }
220 if ($check{implicit_write}) {
3f872cb9 221 if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
a798dbf2
MB
222 warning('Implicit substitution on $_');
223 }
224 }
225}
226
227sub B::LOOP::lint {
228 my $op = shift;
229 if ($check{implicit_read} || $check{implicit_write}) {
3f872cb9 230 if ($op->name eq "enteriter") {
a798dbf2 231 my $last = $op->last;
3f872cb9 232 if ($last->name eq "gv" && $last->gv->NAME eq "_") {
a798dbf2
MB
233 warning('Implicit use of $_ in foreach');
234 }
235 }
236 }
237}
238
7934575e 239sub B::SVOP::lint {
a798dbf2 240 my $op = shift;
3f872cb9 241 if ($check{dollar_underscore} && $op->name eq "gvsv"
a798dbf2
MB
242 && $op->gv->NAME eq "_")
243 {
244 warning('Use of $_');
245 }
246 if ($check{private_names}) {
3f872cb9 247 my $opname = $op->name;
4f25aa18 248 if ($opname eq "gv" || $opname eq "gvsv") {
7934575e
GS
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 }
bfecbe02
RGS
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 }
a798dbf2
MB
258 }
259 }
260 if ($check{undefined_subs}) {
3f872cb9
GS
261 if ($op->name eq "gv"
262 && $op->next->name eq "entersub")
263 {
a798dbf2
MB
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 }
3f872cb9 273 if ($check{regexp_variables} && $op->name eq "gvsv") {
a798dbf2
MB
274 my $name = $op->gv->NAME;
275 if ($name =~ /^[&'`]$/) {
276 warning('Use of regexp variable $%s', $name);
277 }
278 }
279}
280
281sub 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
b0a2b4f5 289 walkoptree_slow($root, "lint") if $$root;
a798dbf2
MB
290}
291
292sub do_lint {
293 my %search_pack;
b0a2b4f5 294 walkoptree_slow(main_root, "lint") if ${main_root()};
a798dbf2
MB
295
296 # Now do subs in main
297 no strict qw(vars refs);
a798dbf2 298 local(*glob);
0091380b
RGS
299 for my $sym (keys %main::) {
300 next if $sym =~ /::$/;
301 *glob = $main::{$sym};
302 svref_2object(\*glob)->EGV->lintcv;
a798dbf2
MB
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
315sub 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 {
7f0faf35 357 if ($opt =~ s/^no_//) {
a798dbf2
MB
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
3711;