This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: expr foreach (...) isn't a B::Lint warning anymore
[perl5.git] / ext / B / B / Lint.pm
CommitLineData
a798dbf2
MB
1package B::Lint;
2
2e9e4ed7 3our $VERSION = '1.06';
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
ca0b1549
JJ
123=head1 EXTENDING LINT
124
125Lint can be extended by registering plugins.
126
fa75652c 127The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
ca0b1549
JJ
128adds the class C<MyPlugin> to the list of plugins. It also adds the
129list of C<@new_checks> to the list of valid checks.
130
fa75652c
RGS
131You must create a C<match( \%checks )> method in your plugin class or one
132of its parents. It will be called on every op as a regular method call
133with a hash ref of checks as its parameter.
ca0b1549 134
fa75652c 135You may not alter the %checks hash reference.
ca0b1549 136
fa75652c
RGS
137The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
138the current filename and line number.
ca0b1549 139
fa75652c
RGS
140 package Sample;
141 use B::Lint;
142 B::Lint->register_plugin( Sample => [ 'good_taste' ] );
143
144 sub match {
145 my ( $op, $checks_href ) = shift;
146 if ( $checks_href->{good_taste} ) {
147 ...
148 }
149 }
ca0b1549 150
a798dbf2
MB
151=head1 BUGS
152
153This is only a very preliminary version.
154
94011a57
JH
155This module doesn't work correctly on thread-enabled perls.
156
a798dbf2
MB
157=head1 AUTHOR
158
159Malcolm Beattie, mbeattie@sable.ox.ac.uk.
160
161=cut
162
163use strict;
b0a2b4f5 164use B qw(walkoptree_slow main_root walksymtable svref_2object parents
ca0b1549 165 class
2e9e4ed7
JJ
166 OPpOUR_INTRO
167 OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
4c1f658f 168 );
a798dbf2
MB
169
170my $file = "unknown"; # shadows current filename
171my $line = 0; # shadows current line number
172my $curstash = "main"; # shadows current stash
173
ca0b1549
JJ
174sub file { $file }
175sub line { $line }
176
a798dbf2
MB
177# Lint checks
178my %check;
179my %implies_ok_context;
180BEGIN {
181 map($implies_ok_context{$_}++,
3f872cb9
GS
182 qw(scalar av2arylen aelem aslice helem hslice
183 keys values hslice defined undef delete));
a798dbf2
MB
184}
185
186# Lint checks turned on by default
187my @default_checks = qw(context);
188
189my %valid_check;
ca0b1549 190my %plugin_valid_check;
a798dbf2
MB
191# All valid checks
192BEGIN {
193 map($valid_check{$_}++,
194 qw(context implicit_read implicit_write dollar_underscore
40f1df11 195 private_names bare_subs undefined_subs regexp_variables));
a798dbf2
MB
196}
197
198# Debugging options
199my ($debug_op);
200
201my %done_cv; # used to mark which subs have already been linted
202my @extra_packages; # Lint checks mainline code and all subs which are
203 # in main:: or in one of these packages.
204
205sub warning {
206 my $format = (@_ < 2) ? "%s" : shift;
207 warn sprintf("$format at %s line %d\n", @_, $file, $line);
208}
209
210# This gimme can't cope with context that's only determined
211# at runtime via dowantarray().
212sub gimme {
213 my $op = shift;
214 my $flags = $op->flags;
4c1f658f 215 if ($flags & OPf_WANT) {
94011a57 216 return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
a798dbf2
MB
217 }
218 return undef;
219}
220
ca0b1549
JJ
221my @plugins;
222
223sub B::OP::lint {
224 my $op = shift;
225 my $m;
226 $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
227 return;
228}
fa75652c 229
ca0b1549
JJ
230*$_ = *B::OP::lint
231 for \ ( *B::PADOP::lint,
232 *B::LOGOP::lint,
233 *B::BINOP::lint,
234 *B::LISTOP::lint );
a798dbf2
MB
235
236sub B::COP::lint {
237 my $op = shift;
3f872cb9 238 if ($op->name eq "nextstate") {
57843af0 239 $file = $op->file;
a798dbf2
MB
240 $line = $op->line;
241 $curstash = $op->stash->NAME;
242 }
ca0b1549
JJ
243
244 my $m;
245 $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
246 return;
a798dbf2
MB
247}
248
249sub B::UNOP::lint {
250 my $op = shift;
3f872cb9
GS
251 my $opname = $op->name;
252 if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
a798dbf2 253 my $parent = parents->[0];
3f872cb9 254 my $pname = $parent->name;
a798dbf2 255 return if gimme($op) || $implies_ok_context{$pname};
2e9e4ed7 256 # Three special cases to deal with: "foreach (@foo)", "delete $a{$b}", and "exists $a{$b}"
a798dbf2 257 # null out the parent so we have to check for a parent of pp_null and
2e9e4ed7 258 # a grandparent of pp_enteriter, pp_delete, pp_exists
3f872cb9
GS
259 if ($pname eq "null") {
260 my $gpname = parents->[1]->name;
2e9e4ed7
JJ
261 return if $gpname eq "enteriter"
262 or $gpname eq "delete"
263 or $gpname eq "exists";
a798dbf2 264 }
2e9e4ed7
JJ
265
266 # our( @bar );
267 return if $op->private & OPpOUR_INTRO
268 and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID;
269
a798dbf2 270 warning("Implicit scalar context for %s in %s",
3f872cb9 271 $opname eq "rv2av" ? "array" : "hash", $parent->desc);
a798dbf2 272 }
3f872cb9 273 if ($check{private_names} && $opname eq "method") {
a798dbf2 274 my $methop = $op->first;
3f872cb9 275 if ($methop->name eq "const") {
a798dbf2
MB
276 my $method = $methop->sv->PV;
277 if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
278 warning("Illegal reference to private method name $method");
279 }
280 }
281 }
ca0b1549
JJ
282
283 my $m;
284 $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
285 return;
a798dbf2
MB
286}
287
288sub B::PMOP::lint {
289 my $op = shift;
290 if ($check{implicit_read}) {
3ee1325f
JJ
291 if ($op->name eq "match"
292 and not ( $op->flags & OPf_STACKED
293 or join( " ",
294 map $_->name,
295 @{B::parents()} )
296 =~ /^(?:leave )?(?:null )*grep/ ) ) {
a798dbf2
MB
297 warning('Implicit match on $_');
298 }
299 }
300 if ($check{implicit_write}) {
3f872cb9 301 if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
a798dbf2
MB
302 warning('Implicit substitution on $_');
303 }
304 }
ca0b1549
JJ
305
306 my $m;
307 $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
308 return;
a798dbf2
MB
309}
310
311sub B::LOOP::lint {
312 my $op = shift;
313 if ($check{implicit_read} || $check{implicit_write}) {
3f872cb9 314 if ($op->name eq "enteriter") {
a798dbf2 315 my $last = $op->last;
2e9e4ed7
JJ
316 my $body = $op->redoop;
317 if ( $last->name eq "gv"
318 and $last->gv->NAME eq "_"
319 and $body->name =~ /\A(?:next|db|set)state\z/ ) {
a798dbf2
MB
320 warning('Implicit use of $_ in foreach');
321 }
322 }
323 }
ca0b1549
JJ
324
325 my $m;
326 $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
327 return;
a798dbf2
MB
328}
329
2e9e4ed7
JJ
330sub _inside_foreach_statement {
331 for my $op ( @{ parents() || [] } ) {
332 $op->name eq 'leaveloop' or next;
333 my $first = $op->first;
334 $first->name eq 'enteriter' or next;
335 $first->redoop->name !~ /\A(?:next|db|set)state\z/ or next;
336 return 1;
337 }
338 return 0;
339}
340
7934575e 341sub B::SVOP::lint {
a798dbf2 342 my $op = shift;
40f1df11
RGS
343 if ( $check{bare_subs} && $op->name eq 'const'
344 && $op->private & 64 ) # OPpCONST_BARE = 64 in op.h
345 {
346 my $sv = $op->sv;
347 if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) {
348 warning "Bare sub name '" . $sv->PV . "' interpreted as string";
349 }
350 }
2e9e4ed7
JJ
351 if ($check{dollar_underscore}
352 and $op->name eq "gvsv"
353 and $op->gv->NAME eq "_"
354 and not ( _inside_foreach_statement()
355 or do { my $ctx = join( ' ',
356 map $_->name,
357 @{ parents() || [] } );
358 $ctx =~ /(grep|map)start \1while/ } ) )
a798dbf2
MB
359 {
360 warning('Use of $_');
361 }
362 if ($check{private_names}) {
3f872cb9 363 my $opname = $op->name;
4f25aa18 364 if ($opname eq "gv" || $opname eq "gvsv") {
7934575e
GS
365 my $gv = $op->gv;
366 if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
367 warning('Illegal reference to private name %s', $gv->NAME);
368 }
bfecbe02
RGS
369 } elsif ($opname eq "method_named") {
370 my $method = $op->gv->PV;
371 if ($method =~ /^_./) {
372 warning("Illegal reference to private method name $method");
373 }
a798dbf2
MB
374 }
375 }
376 if ($check{undefined_subs}) {
3f872cb9
GS
377 if ($op->name eq "gv"
378 && $op->next->name eq "entersub")
379 {
a798dbf2
MB
380 my $gv = $op->gv;
381 my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
382 no strict 'refs';
383 if (!defined(&$subname)) {
384 $subname =~ s/^main:://;
385 warning('Undefined subroutine %s called', $subname);
386 }
387 }
388 }
3f872cb9 389 if ($check{regexp_variables} && $op->name eq "gvsv") {
a798dbf2
MB
390 my $name = $op->gv->NAME;
391 if ($name =~ /^[&'`]$/) {
392 warning('Use of regexp variable $%s', $name);
393 }
394 }
ca0b1549
JJ
395
396 my $m;
397 $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
398 return;
a798dbf2
MB
399}
400
401sub B::GV::lintcv {
402 my $gv = shift;
403 my $cv = $gv->CV;
404 #warn sprintf("lintcv: %s::%s (done=%d)\n",
405 # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
406 return if !$$cv || $done_cv{$$cv}++;
407 my $root = $cv->ROOT;
408 #warn " root = $root (0x$$root)\n";#debug
b0a2b4f5 409 walkoptree_slow($root, "lint") if $$root;
a798dbf2
MB
410}
411
412sub do_lint {
413 my %search_pack;
b0a2b4f5 414 walkoptree_slow(main_root, "lint") if ${main_root()};
a798dbf2
MB
415
416 # Now do subs in main
417 no strict qw(vars refs);
a798dbf2 418 local(*glob);
0091380b
RGS
419 for my $sym (keys %main::) {
420 next if $sym =~ /::$/;
421 *glob = $main::{$sym};
ca0b1549
JJ
422
423 # When is EGV a special value?
424 my $gv = svref_2object(\*glob)->EGV;
425 next if class( $gv ) eq 'SPECIAL';
426 $gv->lintcv;
a798dbf2
MB
427 }
428
429 # Now do subs in non-main packages given by -u options
430 map { $search_pack{$_} = 1 } @extra_packages;
431 walksymtable(\%{"main::"}, "lintcv", sub {
432 my $package = shift;
433 $package =~ s/::$//;
434 #warn "Considering $package\n";#debug
435 return exists $search_pack{$package};
436 });
437}
438
439sub compile {
440 my @options = @_;
441 my ($option, $opt, $arg);
442 # Turn on default lint checks
443 for $opt (@default_checks) {
444 $check{$opt} = 1;
445 }
446 OPTION:
447 while ($option = shift @options) {
448 if ($option =~ /^-(.)(.*)/) {
449 $opt = $1;
450 $arg = $2;
451 } else {
452 unshift @options, $option;
453 last OPTION;
454 }
455 if ($opt eq "-" && $arg eq "-") {
456 shift @options;
457 last OPTION;
458 } elsif ($opt eq "D") {
459 $arg ||= shift @options;
460 foreach $arg (split(//, $arg)) {
461 if ($arg eq "o") {
462 B->debug(1);
463 } elsif ($arg eq "O") {
464 $debug_op = 1;
465 }
466 }
467 } elsif ($opt eq "u") {
468 $arg ||= shift @options;
469 push(@extra_packages, $arg);
470 }
471 }
472 foreach $opt (@default_checks, @options) {
473 $opt =~ tr/-/_/;
474 if ($opt eq "all") {
ca0b1549 475 %check = ( %valid_check, %plugin_valid_check );
a798dbf2
MB
476 }
477 elsif ($opt eq "none") {
478 %check = ();
479 }
480 else {
7f0faf35 481 if ($opt =~ s/^no_//) {
a798dbf2
MB
482 $check{$opt} = 0;
483 }
484 else {
485 $check{$opt} = 1;
486 }
ca0b1549
JJ
487 warn "No such check: $opt\n" unless defined $valid_check{$opt}
488 or defined $plugin_valid_check{$opt};
a798dbf2
MB
489 }
490 }
491 # Remaining arguments are things to check
fa75652c 492
a798dbf2
MB
493 return \&do_lint;
494}
495
ca0b1549
JJ
496sub register_plugin {
497 my ( undef, $plugin, $new_checks ) = @_;
fa75652c 498
ca0b1549
JJ
499 # Register the plugin
500 for my $check ( @$new_checks ) {
501 defined $check
502 or warn "Undefined value in checks.";
503 not $valid_check{ $check }
504 or warn "$check is already registered as a B::Lint feature.";
505 not $plugin_valid_check{ $check }
506 or warn "$check is already registered as a $plugin_valid_check{$check} feature.";
fa75652c 507
ca0b1549
JJ
508 $plugin_valid_check{$check} = $plugin;
509 }
fa75652c 510
ca0b1549 511 push @plugins, $plugin;
fa75652c 512
ca0b1549
JJ
513 return;
514}
515
a798dbf2 5161;