This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add the fruits of Larry Shatzer's version verifying script.
[perl5.git] / ext / B / B / Lint.pm
1 package B::Lint;
2
3 our $VERSION = '1.00';
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 =head1 AUTHOR
115
116 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
117
118 =cut
119
120 use strict;
121 use B qw(walkoptree main_root walksymtable svref_2object parents
122          OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
123         );
124
125 my $file = "unknown";           # shadows current filename
126 my $line = 0;                   # shadows current line number
127 my $curstash = "main";          # shadows current stash
128
129 # Lint checks
130 my %check;
131 my %implies_ok_context;
132 BEGIN {
133     map($implies_ok_context{$_}++,
134         qw(scalar av2arylen aelem aslice helem hslice
135            keys values hslice defined undef delete));
136 }
137
138 # Lint checks turned on by default
139 my @default_checks = qw(context);
140
141 my %valid_check;
142 # All valid checks
143 BEGIN {
144     map($valid_check{$_}++,
145         qw(context implicit_read implicit_write dollar_underscore
146            private_names undefined_subs regexp_variables));
147 }
148
149 # Debugging options
150 my ($debug_op);
151
152 my %done_cv;            # used to mark which subs have already been linted
153 my @extra_packages;     # Lint checks mainline code and all subs which are
154                         # in main:: or in one of these packages.
155
156 sub warning {
157     my $format = (@_ < 2) ? "%s" : shift;
158     warn sprintf("$format at %s line %d\n", @_, $file, $line);
159 }
160
161 # This gimme can't cope with context that's only determined
162 # at runtime via dowantarray().
163 sub gimme {
164     my $op = shift;
165     my $flags = $op->flags;
166     if ($flags & OPf_WANT) {
167         return(($flags & OPf_WANT_LIST) ? 1 : 0);
168     }
169     return undef;
170 }
171
172 sub B::OP::lint {}
173
174 sub B::COP::lint {
175     my $op = shift;
176     if ($op->name eq "nextstate") {
177         $file = $op->file;
178         $line = $op->line;
179         $curstash = $op->stash->NAME;
180     }
181 }
182
183 sub B::UNOP::lint {
184     my $op = shift;
185     my $opname = $op->name;
186     if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
187         my $parent = parents->[0];
188         my $pname = $parent->name;
189         return if gimme($op) || $implies_ok_context{$pname};
190         # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
191         # null out the parent so we have to check for a parent of pp_null and
192         # a grandparent of pp_enteriter or pp_delete
193         if ($pname eq "null") {
194             my $gpname = parents->[1]->name;
195             return if $gpname eq "enteriter" || $gpname eq "delete";
196         }
197         warning("Implicit scalar context for %s in %s",
198                 $opname eq "rv2av" ? "array" : "hash", $parent->desc);
199     }
200     if ($check{private_names} && $opname eq "method") {
201         my $methop = $op->first;
202         if ($methop->name eq "const") {
203             my $method = $methop->sv->PV;
204             if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
205                 warning("Illegal reference to private method name $method");
206             }
207         }
208     }
209 }
210
211 sub B::PMOP::lint {
212     my $op = shift;
213     if ($check{implicit_read}) {
214         if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
215             warning('Implicit match on $_');
216         }
217     }
218     if ($check{implicit_write}) {
219         if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
220             warning('Implicit substitution on $_');
221         }
222     }
223 }
224
225 sub B::LOOP::lint {
226     my $op = shift;
227     if ($check{implicit_read} || $check{implicit_write}) {
228         if ($op->name eq "enteriter") {
229             my $last = $op->last;
230             if ($last->name eq "gv" && $last->gv->NAME eq "_") {
231                 warning('Implicit use of $_ in foreach');
232             }
233         }
234     }
235 }
236
237 sub B::SVOP::lint {
238     my $op = shift;
239     if ($check{dollar_underscore} && $op->name eq "gvsv"
240         && $op->gv->NAME eq "_")
241     {
242         warning('Use of $_');
243     }
244     if ($check{private_names}) {
245         my $opname = $op->name;
246         if ($opname eq "gv" || $opname eq "gvsv") {
247             my $gv = $op->gv;
248             if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
249                 warning('Illegal reference to private name %s', $gv->NAME);
250             }
251         }
252     }
253     if ($check{undefined_subs}) {
254         if ($op->name eq "gv"
255             && $op->next->name eq "entersub")
256         {
257             my $gv = $op->gv;
258             my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
259             no strict 'refs';
260             if (!defined(&$subname)) {
261                 $subname =~ s/^main:://;
262                 warning('Undefined subroutine %s called', $subname);
263             }
264         }
265     }
266     if ($check{regexp_variables} && $op->name eq "gvsv") {
267         my $name = $op->gv->NAME;
268         if ($name =~ /^[&'`]$/) {
269             warning('Use of regexp variable $%s', $name);
270         }
271     }
272 }
273
274 sub B::GV::lintcv {
275     my $gv = shift;
276     my $cv = $gv->CV;
277     #warn sprintf("lintcv: %s::%s (done=%d)\n",
278     #            $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
279     return if !$$cv || $done_cv{$$cv}++;
280     my $root = $cv->ROOT;
281     #warn "    root = $root (0x$$root)\n";#debug
282     walkoptree($root, "lint") if $$root;
283 }
284
285 sub do_lint {
286     my %search_pack;
287     walkoptree(main_root, "lint") if ${main_root()};
288     
289     # Now do subs in main
290     no strict qw(vars refs);
291     my $sym;
292     local(*glob);
293     while (($sym, *glob) = each %{"main::"}) {
294         #warn "Trying $sym\n";#debug
295         svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/;
296     }
297
298     # Now do subs in non-main packages given by -u options
299     map { $search_pack{$_} = 1 } @extra_packages;
300     walksymtable(\%{"main::"}, "lintcv", sub {
301         my $package = shift;
302         $package =~ s/::$//;
303         #warn "Considering $package\n";#debug
304         return exists $search_pack{$package};
305     });
306 }
307
308 sub compile {
309     my @options = @_;
310     my ($option, $opt, $arg);
311     # Turn on default lint checks
312     for $opt (@default_checks) {
313         $check{$opt} = 1;
314     }
315   OPTION:
316     while ($option = shift @options) {
317         if ($option =~ /^-(.)(.*)/) {
318             $opt = $1;
319             $arg = $2;
320         } else {
321             unshift @options, $option;
322             last OPTION;
323         }
324         if ($opt eq "-" && $arg eq "-") {
325             shift @options;
326             last OPTION;
327         } elsif ($opt eq "D") {
328             $arg ||= shift @options;
329             foreach $arg (split(//, $arg)) {
330                 if ($arg eq "o") {
331                     B->debug(1);
332                 } elsif ($arg eq "O") {
333                     $debug_op = 1;
334                 }
335             }
336         } elsif ($opt eq "u") {
337             $arg ||= shift @options;
338             push(@extra_packages, $arg);
339         }
340     }
341     foreach $opt (@default_checks, @options) {
342         $opt =~ tr/-/_/;
343         if ($opt eq "all") {
344             %check = %valid_check;
345         }
346         elsif ($opt eq "none") {
347             %check = ();
348         }
349         else {
350             if ($opt =~ s/^no_//) {
351                 $check{$opt} = 0;
352             }
353             else {
354                 $check{$opt} = 1;
355             }
356             warn "No such check: $opt\n" unless defined $valid_check{$opt};
357         }
358     }
359     # Remaining arguments are things to check
360     
361     return \&do_lint;
362 }
363
364 1;