This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
POD nits on B::Lint
[perl5.git] / ext / B / B / Lint.pm
1 package B::Lint;
2
3 our $VERSION = '1.04';
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          OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
167         );
168
169 my $file = "unknown";           # shadows current filename
170 my $line = 0;                   # shadows current line number
171 my $curstash = "main";          # shadows current stash
172
173 sub file { $file }
174 sub line { $line }
175
176 # Lint checks
177 my %check;
178 my %implies_ok_context;
179 BEGIN {
180     map($implies_ok_context{$_}++,
181         qw(scalar av2arylen aelem aslice helem hslice
182            keys values hslice defined undef delete));
183 }
184
185 # Lint checks turned on by default
186 my @default_checks = qw(context);
187
188 my %valid_check;
189 my %plugin_valid_check;
190 # All valid checks
191 BEGIN {
192     map($valid_check{$_}++,
193         qw(context implicit_read implicit_write dollar_underscore
194            private_names bare_subs undefined_subs regexp_variables));
195 }
196
197 # Debugging options
198 my ($debug_op);
199
200 my %done_cv;            # used to mark which subs have already been linted
201 my @extra_packages;     # Lint checks mainline code and all subs which are
202                         # in main:: or in one of these packages.
203
204 sub warning {
205     my $format = (@_ < 2) ? "%s" : shift;
206     warn sprintf("$format at %s line %d\n", @_, $file, $line);
207 }
208
209 # This gimme can't cope with context that's only determined
210 # at runtime via dowantarray().
211 sub gimme {
212     my $op = shift;
213     my $flags = $op->flags;
214     if ($flags & OPf_WANT) {
215         return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
216     }
217     return undef;
218 }
219
220 my @plugins;
221
222 sub B::OP::lint {
223     my $op = shift;
224     my $m;
225     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
226     return;
227 }
228
229 *$_ = *B::OP::lint
230   for \ ( *B::PADOP::lint,
231           *B::LOGOP::lint,
232           *B::BINOP::lint,
233           *B::LISTOP::lint );
234
235 sub B::COP::lint {
236     my $op = shift;
237     if ($op->name eq "nextstate") {
238         $file = $op->file;
239         $line = $op->line;
240         $curstash = $op->stash->NAME;
241     }
242
243     my $m;
244     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
245     return;
246 }
247
248 sub B::UNOP::lint {
249     my $op = shift;
250     my $opname = $op->name;
251     if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
252         my $parent = parents->[0];
253         my $pname = $parent->name;
254         return if gimme($op) || $implies_ok_context{$pname};
255         # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
256         # null out the parent so we have to check for a parent of pp_null and
257         # a grandparent of pp_enteriter or pp_delete
258         if ($pname eq "null") {
259             my $gpname = parents->[1]->name;
260             return if $gpname eq "enteriter" || $gpname eq "delete";
261         }
262         warning("Implicit scalar context for %s in %s",
263                 $opname eq "rv2av" ? "array" : "hash", $parent->desc);
264     }
265     if ($check{private_names} && $opname eq "method") {
266         my $methop = $op->first;
267         if ($methop->name eq "const") {
268             my $method = $methop->sv->PV;
269             if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
270                 warning("Illegal reference to private method name $method");
271             }
272         }
273     }
274
275     my $m;
276     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
277     return;
278 }
279
280 sub B::PMOP::lint {
281     my $op = shift;
282     if ($check{implicit_read}) {
283         if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
284             warning('Implicit match on $_');
285         }
286     }
287     if ($check{implicit_write}) {
288         if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
289             warning('Implicit substitution on $_');
290         }
291     }
292
293     my $m;
294     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
295     return;
296 }
297
298 sub B::LOOP::lint {
299     my $op = shift;
300     if ($check{implicit_read} || $check{implicit_write}) {
301         if ($op->name eq "enteriter") {
302             my $last = $op->last;
303             if ($last->name eq "gv" && $last->gv->NAME eq "_") {
304                 warning('Implicit use of $_ in foreach');
305             }
306         }
307     }
308     
309     my $m;
310     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
311     return;
312 }
313
314 sub B::SVOP::lint {
315     my $op = shift;
316     if ( $check{bare_subs} && $op->name eq 'const'
317          && $op->private & 64 )         # OPpCONST_BARE = 64 in op.h
318     {
319         my $sv = $op->sv;
320         if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) {
321             warning "Bare sub name '" . $sv->PV . "' interpreted as string";
322         }
323     }
324     if ($check{dollar_underscore} && $op->name eq "gvsv"
325         && $op->gv->NAME eq "_")
326     {
327         warning('Use of $_');
328     }
329     if ($check{private_names}) {
330         my $opname = $op->name;
331         if ($opname eq "gv" || $opname eq "gvsv") {
332             my $gv = $op->gv;
333             if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
334                 warning('Illegal reference to private name %s', $gv->NAME);
335             }
336         } elsif ($opname eq "method_named") {
337             my $method = $op->gv->PV;
338             if ($method =~ /^_./) {
339                 warning("Illegal reference to private method name $method");
340             }
341         }
342     }
343     if ($check{undefined_subs}) {
344         if ($op->name eq "gv"
345             && $op->next->name eq "entersub")
346         {
347             my $gv = $op->gv;
348             my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
349             no strict 'refs';
350             if (!defined(&$subname)) {
351                 $subname =~ s/^main:://;
352                 warning('Undefined subroutine %s called', $subname);
353             }
354         }
355     }
356     if ($check{regexp_variables} && $op->name eq "gvsv") {
357         my $name = $op->gv->NAME;
358         if ($name =~ /^[&'`]$/) {
359             warning('Use of regexp variable $%s', $name);
360         }
361     }
362     
363     my $m;
364     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
365     return;
366 }
367
368 sub B::GV::lintcv {
369     my $gv = shift;
370     my $cv = $gv->CV;
371     #warn sprintf("lintcv: %s::%s (done=%d)\n",
372     #            $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
373     return if !$$cv || $done_cv{$$cv}++;
374     my $root = $cv->ROOT;
375     #warn "    root = $root (0x$$root)\n";#debug
376     walkoptree_slow($root, "lint") if $$root;
377 }
378
379 sub do_lint {
380     my %search_pack;
381     walkoptree_slow(main_root, "lint") if ${main_root()};
382     
383     # Now do subs in main
384     no strict qw(vars refs);
385     local(*glob);
386     for my $sym (keys %main::) {
387         next if $sym =~ /::$/;
388         *glob = $main::{$sym};
389         
390         # When is EGV a special value?
391         my $gv = svref_2object(\*glob)->EGV;
392         next if class( $gv ) eq 'SPECIAL';
393         $gv->lintcv;
394     }
395
396     # Now do subs in non-main packages given by -u options
397     map { $search_pack{$_} = 1 } @extra_packages;
398     walksymtable(\%{"main::"}, "lintcv", sub {
399         my $package = shift;
400         $package =~ s/::$//;
401         #warn "Considering $package\n";#debug
402         return exists $search_pack{$package};
403     });
404 }
405
406 sub compile {
407     my @options = @_;
408     my ($option, $opt, $arg);
409     # Turn on default lint checks
410     for $opt (@default_checks) {
411         $check{$opt} = 1;
412     }
413   OPTION:
414     while ($option = shift @options) {
415         if ($option =~ /^-(.)(.*)/) {
416             $opt = $1;
417             $arg = $2;
418         } else {
419             unshift @options, $option;
420             last OPTION;
421         }
422         if ($opt eq "-" && $arg eq "-") {
423             shift @options;
424             last OPTION;
425         } elsif ($opt eq "D") {
426             $arg ||= shift @options;
427             foreach $arg (split(//, $arg)) {
428                 if ($arg eq "o") {
429                     B->debug(1);
430                 } elsif ($arg eq "O") {
431                     $debug_op = 1;
432                 }
433             }
434         } elsif ($opt eq "u") {
435             $arg ||= shift @options;
436             push(@extra_packages, $arg);
437         }
438     }
439     foreach $opt (@default_checks, @options) {
440         $opt =~ tr/-/_/;
441         if ($opt eq "all") {
442             %check = ( %valid_check, %plugin_valid_check );
443         }
444         elsif ($opt eq "none") {
445             %check = ();
446         }
447         else {
448             if ($opt =~ s/^no_//) {
449                 $check{$opt} = 0;
450             }
451             else {
452                 $check{$opt} = 1;
453             }
454             warn "No such check: $opt\n" unless defined $valid_check{$opt}
455                                              or defined $plugin_valid_check{$opt};
456         }
457     }
458     # Remaining arguments are things to check
459
460     return \&do_lint;
461 }
462
463 sub register_plugin {
464     my ( undef, $plugin, $new_checks ) = @_;
465
466     # Register the plugin
467     for my $check ( @$new_checks ) {
468         defined $check
469           or warn "Undefined value in checks.";
470         not $valid_check{ $check }
471           or warn "$check is already registered as a B::Lint feature.";
472         not $plugin_valid_check{ $check }
473           or warn "$check is already registered as a $plugin_valid_check{$check} feature.";
474
475         $plugin_valid_check{$check} = $plugin;
476     }
477
478     push @plugins, $plugin;
479
480     return;
481 }
482
483 1;