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