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
1 package B::Lint;
2
3 our $VERSION = '1.06';
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 F<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
40 will elicit a warning. Using an explicit B<scalar()> silences the
41 warning. For example,
42
43     $foo = scalar(@bar);
44
45 =item B<implicit-read> and B<implicit-write>
46
47 These options produce a warning whenever an operation implicitly
48 reads or (respectively) writes to one of Perl's special variables.
49 For example, B<implicit-read> will warn about these:
50
51     /foo/;
52
53 and B<implicit-write> will warn about these:
54
55     s/foo/bar/;
56
57 Both B<implicit-read> and B<implicit-write> warn about this:
58
59     for (@a) { ... }
60
61 =item B<bare-subs>
62
63 This option warns whenever a bareword is implicitly quoted, but is also
64 the name of a subroutine in the current package. Typical mistakes that it will
65 trap are:
66
67     use constant foo => 'bar';
68     @a = ( foo => 1 );
69     $b{foo} = 2;
70
71 Neither of these will do what a naive user would expect.
72
73 =item B<dollar-underscore>
74
75 This option warns whenever C<$_> is used either explicitly anywhere or
76 as the implicit argument of a B<print> statement.
77
78 =item B<private-names>
79
80 This option warns on each use of any variable, subroutine or
81 method name that lives in a non-current package but begins with
82 an underscore ("_"). Warnings aren't issued for the special case
83 of the single character name "_" by itself (e.g. C<$_> and C<@_>).
84
85 =item B<undefined-subs>
86
87 This option warns whenever an undefined subroutine is invoked.
88 This option will only catch explicitly invoked subroutines such
89 as C<foo()> and not indirect invocations such as C<&$subref()>
90 or C<$obj-E<gt>meth()>. Note that some programs or modules delay
91 definition of subs until runtime by means of the AUTOLOAD
92 mechanism.
93
94 =item B<regexp-variables>
95
96 This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
97 is used. Any occurrence of any of these variables in your
98 program can slow your whole program down. See L<perlre> for
99 details.
100
101 =item B<all>
102
103 Turn all warnings on.
104
105 =item B<none>
106
107 Turn all warnings off.
108
109 =back
110
111 =head1 NON LINT-CHECK OPTIONS
112
113 =over 8
114
115 =item B<-u Package>
116
117 Normally, Lint only checks the main code of the program together
118 with all subs defined in package main. The B<-u> option lets you
119 include other package names whose subs are then checked by Lint.
120
121 =back
122
123 =head1 EXTENDING LINT
124
125 Lint can be extended by registering plugins.
126
127 The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
128 adds the class C<MyPlugin> to the list of plugins. It also adds the
129 list of C<@new_checks> to the list of valid checks.
130
131 You must create a C<match( \%checks )> method in your plugin class or one
132 of its parents. It will be called on every op as a regular method call
133 with a hash ref of checks as its parameter.
134
135 You may not alter the %checks hash reference.
136
137 The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
138 the current filename and line number.
139
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   }
150
151 =head1 BUGS
152
153 This is only a very preliminary version.
154
155 This module doesn't work correctly on thread-enabled perls.
156
157 =head1 AUTHOR
158
159 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
160
161 =cut
162
163 use strict;
164 use B qw(walkoptree_slow main_root walksymtable svref_2object parents
165          class
166          OPpOUR_INTRO
167          OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
168         );
169
170 my $file = "unknown";           # shadows current filename
171 my $line = 0;                   # shadows current line number
172 my $curstash = "main";          # shadows current stash
173
174 sub file { $file }
175 sub line { $line }
176
177 # Lint checks
178 my %check;
179 my %implies_ok_context;
180 BEGIN {
181     map($implies_ok_context{$_}++,
182         qw(scalar av2arylen aelem aslice helem hslice
183            keys values hslice defined undef delete));
184 }
185
186 # Lint checks turned on by default
187 my @default_checks = qw(context);
188
189 my %valid_check;
190 my %plugin_valid_check;
191 # All valid checks
192 BEGIN {
193     map($valid_check{$_}++,
194         qw(context implicit_read implicit_write dollar_underscore
195            private_names bare_subs undefined_subs regexp_variables));
196 }
197
198 # Debugging options
199 my ($debug_op);
200
201 my %done_cv;            # used to mark which subs have already been linted
202 my @extra_packages;     # Lint checks mainline code and all subs which are
203                         # in main:: or in one of these packages.
204
205 sub 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().
212 sub gimme {
213     my $op = shift;
214     my $flags = $op->flags;
215     if ($flags & OPf_WANT) {
216         return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
217     }
218     return undef;
219 }
220
221 my @plugins;
222
223 sub B::OP::lint {
224     my $op = shift;
225     my $m;
226     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
227     return;
228 }
229
230 *$_ = *B::OP::lint
231   for \ ( *B::PADOP::lint,
232           *B::LOGOP::lint,
233           *B::BINOP::lint,
234           *B::LISTOP::lint );
235
236 sub B::COP::lint {
237     my $op = shift;
238     if ($op->name eq "nextstate") {
239         $file = $op->file;
240         $line = $op->line;
241         $curstash = $op->stash->NAME;
242     }
243
244     my $m;
245     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
246     return;
247 }
248
249 sub B::UNOP::lint {
250     my $op = shift;
251     my $opname = $op->name;
252     if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
253         my $parent = parents->[0];
254         my $pname = $parent->name;
255         return if gimme($op) || $implies_ok_context{$pname};
256         # Three special cases to deal with: "foreach (@foo)", "delete $a{$b}", and "exists $a{$b}"
257         # null out the parent so we have to check for a parent of pp_null and
258         # a grandparent of pp_enteriter, pp_delete, pp_exists
259         if ($pname eq "null") {
260             my $gpname = parents->[1]->name;
261             return if $gpname eq "enteriter"
262                    or $gpname eq "delete"
263                    or $gpname eq "exists";
264         }
265         
266         # our( @bar );
267         return if $op->private & OPpOUR_INTRO
268                   and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID;
269         
270         warning("Implicit scalar context for %s in %s",
271                 $opname eq "rv2av" ? "array" : "hash", $parent->desc);
272     }
273     if ($check{private_names} && $opname eq "method") {
274         my $methop = $op->first;
275         if ($methop->name eq "const") {
276             my $method = $methop->sv->PV;
277             if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
278                 warning("Illegal reference to private method name $method");
279             }
280         }
281     }
282
283     my $m;
284     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
285     return;
286 }
287
288 sub B::PMOP::lint {
289     my $op = shift;
290     if ($check{implicit_read}) {
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/ ) ) {
297             warning('Implicit match on $_');
298         }
299     }
300     if ($check{implicit_write}) {
301         if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
302             warning('Implicit substitution on $_');
303         }
304     }
305
306     my $m;
307     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
308     return;
309 }
310
311 sub B::LOOP::lint {
312     my $op = shift;
313     if ($check{implicit_read} || $check{implicit_write}) {
314         if ($op->name eq "enteriter") {
315             my $last = $op->last;
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/ ) {
320                 warning('Implicit use of $_ in foreach');
321             }
322         }
323     }
324     
325     my $m;
326     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
327     return;
328 }
329
330 sub _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
341 sub B::SVOP::lint {
342     my $op = shift;
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     }
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/ } ) )
359     {
360         warning('Use of $_');
361     }
362     if ($check{private_names}) {
363         my $opname = $op->name;
364         if ($opname eq "gv" || $opname eq "gvsv") {
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             }
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             }
374         }
375     }
376     if ($check{undefined_subs}) {
377         if ($op->name eq "gv"
378             && $op->next->name eq "entersub")
379         {
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     }
389     if ($check{regexp_variables} && $op->name eq "gvsv") {
390         my $name = $op->gv->NAME;
391         if ($name =~ /^[&'`]$/) {
392             warning('Use of regexp variable $%s', $name);
393         }
394     }
395     
396     my $m;
397     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
398     return;
399 }
400
401 sub 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
409     walkoptree_slow($root, "lint") if $$root;
410 }
411
412 sub do_lint {
413     my %search_pack;
414     walkoptree_slow(main_root, "lint") if ${main_root()};
415     
416     # Now do subs in main
417     no strict qw(vars refs);
418     local(*glob);
419     for my $sym (keys %main::) {
420         next if $sym =~ /::$/;
421         *glob = $main::{$sym};
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;
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
439 sub 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") {
475             %check = ( %valid_check, %plugin_valid_check );
476         }
477         elsif ($opt eq "none") {
478             %check = ();
479         }
480         else {
481             if ($opt =~ s/^no_//) {
482                 $check{$opt} = 0;
483             }
484             else {
485                 $check{$opt} = 1;
486             }
487             warn "No such check: $opt\n" unless defined $valid_check{$opt}
488                                              or defined $plugin_valid_check{$opt};
489         }
490     }
491     # Remaining arguments are things to check
492
493     return \&do_lint;
494 }
495
496 sub register_plugin {
497     my ( undef, $plugin, $new_checks ) = @_;
498
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.";
507
508         $plugin_valid_check{$check} = $plugin;
509     }
510
511     push @plugins, $plugin;
512
513     return;
514 }
515
516 1;