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