Remove pseudo-hashes (complete)
[p5sagit/p5-mst-13.2.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         } elsif ($opname eq "method_named") {
254             my $method = $op->gv->PV;
255             if ($method =~ /^_./) {
256                 warning("Illegal reference to private method name $method");
257             }
258         }
259     }
260     if ($check{undefined_subs}) {
261         if ($op->name eq "gv"
262             && $op->next->name eq "entersub")
263         {
264             my $gv = $op->gv;
265             my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
266             no strict 'refs';
267             if (!defined(&$subname)) {
268                 $subname =~ s/^main:://;
269                 warning('Undefined subroutine %s called', $subname);
270             }
271         }
272     }
273     if ($check{regexp_variables} && $op->name eq "gvsv") {
274         my $name = $op->gv->NAME;
275         if ($name =~ /^[&'`]$/) {
276             warning('Use of regexp variable $%s', $name);
277         }
278     }
279 }
280
281 sub B::GV::lintcv {
282     my $gv = shift;
283     my $cv = $gv->CV;
284     #warn sprintf("lintcv: %s::%s (done=%d)\n",
285     #            $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
286     return if !$$cv || $done_cv{$$cv}++;
287     my $root = $cv->ROOT;
288     #warn "    root = $root (0x$$root)\n";#debug
289     walkoptree_slow($root, "lint") if $$root;
290 }
291
292 sub do_lint {
293     my %search_pack;
294     walkoptree_slow(main_root, "lint") if ${main_root()};
295     
296     # Now do subs in main
297     no strict qw(vars refs);
298     local(*glob);
299     for my $sym (keys %main::) {
300         next if $sym =~ /::$/;
301         *glob = $main::{$sym};
302         svref_2object(\*glob)->EGV->lintcv;
303     }
304
305     # Now do subs in non-main packages given by -u options
306     map { $search_pack{$_} = 1 } @extra_packages;
307     walksymtable(\%{"main::"}, "lintcv", sub {
308         my $package = shift;
309         $package =~ s/::$//;
310         #warn "Considering $package\n";#debug
311         return exists $search_pack{$package};
312     });
313 }
314
315 sub compile {
316     my @options = @_;
317     my ($option, $opt, $arg);
318     # Turn on default lint checks
319     for $opt (@default_checks) {
320         $check{$opt} = 1;
321     }
322   OPTION:
323     while ($option = shift @options) {
324         if ($option =~ /^-(.)(.*)/) {
325             $opt = $1;
326             $arg = $2;
327         } else {
328             unshift @options, $option;
329             last OPTION;
330         }
331         if ($opt eq "-" && $arg eq "-") {
332             shift @options;
333             last OPTION;
334         } elsif ($opt eq "D") {
335             $arg ||= shift @options;
336             foreach $arg (split(//, $arg)) {
337                 if ($arg eq "o") {
338                     B->debug(1);
339                 } elsif ($arg eq "O") {
340                     $debug_op = 1;
341                 }
342             }
343         } elsif ($opt eq "u") {
344             $arg ||= shift @options;
345             push(@extra_packages, $arg);
346         }
347     }
348     foreach $opt (@default_checks, @options) {
349         $opt =~ tr/-/_/;
350         if ($opt eq "all") {
351             %check = %valid_check;
352         }
353         elsif ($opt eq "none") {
354             %check = ();
355         }
356         else {
357             if ($opt =~ s/^no_//) {
358                 $check{$opt} = 0;
359             }
360             else {
361                 $check{$opt} = 1;
362             }
363             warn "No such check: $opt\n" unless defined $valid_check{$opt};
364         }
365     }
366     # Remaining arguments are things to check
367     
368     return \&do_lint;
369 }
370
371 1;