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