Commit | Line | Data |
a798dbf2 |
1 | package B::Lint; |
2 | |
c97a6147 |
3 | our $VERSION = '1.11'; ## no critic |
28b605d8 |
4 | |
a798dbf2 |
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> |
c00253d5 |
16 | option of B<perl>. It is named after the program F<lint> which carries |
a798dbf2 |
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 | |
9b494a7e |
32 | =item B<magic-diamond> |
33 | |
34 | Produces a warning whenever the magic C<E<lt>E<gt>> readline is |
35 | used. Internally it uses perl's two-argument open which itself treats |
36 | filenames with special characters specially. This could allow |
37 | interestingly named files to have unexpected effects when reading. |
38 | |
39 | % touch 'rm *|' |
40 | % perl -pe 1 |
41 | |
42 | The above creates a file named C<rm *|>. When perl opens it with |
43 | C<E<lt>E<gt>> it actually executes the shell program C<rm *>. This |
44 | makes C<E<lt>E<gt>> dangerous to use carelessly. |
45 | |
a798dbf2 |
46 | =item B<context> |
47 | |
48 | Produces a warning whenever an array is used in an implicit scalar |
49 | context. For example, both of the lines |
50 | |
51 | $foo = length(@bar); |
52 | $foo = @bar; |
c00253d5 |
53 | |
a798dbf2 |
54 | will elicit a warning. Using an explicit B<scalar()> silences the |
55 | warning. For example, |
56 | |
57 | $foo = scalar(@bar); |
58 | |
59 | =item B<implicit-read> and B<implicit-write> |
60 | |
61 | These options produce a warning whenever an operation implicitly |
62 | reads or (respectively) writes to one of Perl's special variables. |
63 | For example, B<implicit-read> will warn about these: |
64 | |
65 | /foo/; |
66 | |
67 | and B<implicit-write> will warn about these: |
68 | |
69 | s/foo/bar/; |
70 | |
71 | Both B<implicit-read> and B<implicit-write> warn about this: |
72 | |
73 | for (@a) { ... } |
74 | |
40f1df11 |
75 | =item B<bare-subs> |
76 | |
77 | This option warns whenever a bareword is implicitly quoted, but is also |
78 | the name of a subroutine in the current package. Typical mistakes that it will |
79 | trap are: |
80 | |
c00253d5 |
81 | use constant foo => 'bar'; |
82 | @a = ( foo => 1 ); |
83 | $b{foo} = 2; |
40f1df11 |
84 | |
85 | Neither of these will do what a naive user would expect. |
86 | |
a798dbf2 |
87 | =item B<dollar-underscore> |
88 | |
c00253d5 |
89 | This option warns whenever C<$_> is used either explicitly anywhere or |
a798dbf2 |
90 | as the implicit argument of a B<print> statement. |
91 | |
92 | =item B<private-names> |
93 | |
94 | This option warns on each use of any variable, subroutine or |
95 | method name that lives in a non-current package but begins with |
96 | an underscore ("_"). Warnings aren't issued for the special case |
c00253d5 |
97 | of the single character name "_" by itself (e.g. C<$_> and C<@_>). |
a798dbf2 |
98 | |
99 | =item B<undefined-subs> |
100 | |
101 | This option warns whenever an undefined subroutine is invoked. |
102 | This option will only catch explicitly invoked subroutines such |
103 | as C<foo()> and not indirect invocations such as C<&$subref()> |
104 | or C<$obj-E<gt>meth()>. Note that some programs or modules delay |
105 | definition of subs until runtime by means of the AUTOLOAD |
106 | mechanism. |
107 | |
108 | =item B<regexp-variables> |
109 | |
c00253d5 |
110 | This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'> |
111 | is used. Any occurrence of any of these variables in your |
a798dbf2 |
112 | program can slow your whole program down. See L<perlre> for |
113 | details. |
114 | |
115 | =item B<all> |
116 | |
117 | Turn all warnings on. |
118 | |
119 | =item B<none> |
120 | |
121 | Turn all warnings off. |
122 | |
123 | =back |
124 | |
125 | =head1 NON LINT-CHECK OPTIONS |
126 | |
127 | =over 8 |
128 | |
129 | =item B<-u Package> |
130 | |
131 | Normally, Lint only checks the main code of the program together |
132 | with all subs defined in package main. The B<-u> option lets you |
133 | include other package names whose subs are then checked by Lint. |
134 | |
135 | =back |
136 | |
ca0b1549 |
137 | =head1 EXTENDING LINT |
138 | |
2adc4a42 |
139 | Lint can be extended by with plugins. Lint uses L<Module::Pluggable> |
140 | to find available plugins. Plugins are expected but not required to |
141 | inform Lint of which checks they are adding. |
ca0b1549 |
142 | |
fa75652c |
143 | The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method |
2adc4a42 |
144 | adds the list of C<@new_checks> to the list of valid checks. If your |
145 | module wasn't loaded by L<Module::Pluggable> then your class name is |
146 | added to the list of plugins. |
ca0b1549 |
147 | |
fa75652c |
148 | You must create a C<match( \%checks )> method in your plugin class or one |
149 | of its parents. It will be called on every op as a regular method call |
150 | with a hash ref of checks as its parameter. |
ca0b1549 |
151 | |
fa75652c |
152 | The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain |
153 | the current filename and line number. |
ca0b1549 |
154 | |
fa75652c |
155 | package Sample; |
156 | use B::Lint; |
157 | B::Lint->register_plugin( Sample => [ 'good_taste' ] ); |
158 | |
159 | sub match { |
9b494a7e |
160 | my ( $op, $checks_href ) = shift @_; |
fa75652c |
161 | if ( $checks_href->{good_taste} ) { |
162 | ... |
163 | } |
164 | } |
ca0b1549 |
165 | |
9b494a7e |
166 | =head1 TODO |
167 | |
168 | =over |
169 | |
170 | =item while(<FH>) stomps $_ |
171 | |
172 | =item strict oo |
173 | |
174 | =item unchecked system calls |
175 | |
176 | =item more tests, validate against older perls |
177 | |
d5e42f17 |
178 | =back |
179 | |
a798dbf2 |
180 | =head1 BUGS |
181 | |
182 | This is only a very preliminary version. |
183 | |
184 | =head1 AUTHOR |
185 | |
186 | Malcolm Beattie, mbeattie@sable.ox.ac.uk. |
187 | |
c97a6147 |
188 | =head1 ACKNOWLEDGEMENTS |
189 | |
190 | Sebastien Aperghis-Tramoni - bug fixes |
191 | |
a798dbf2 |
192 | =cut |
193 | |
194 | use strict; |
9b494a7e |
195 | use B qw( walkoptree_slow |
196 | main_root main_cv walksymtable parents |
197 | OPpOUR_INTRO |
198 | OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED SVf_POK ); |
2adc4a42 |
199 | use Carp 'carp'; |
200 | |
201 | # The current M::P doesn't know about .pmc files. |
202 | use Module::Pluggable ( require => 1 ); |
203 | |
204 | use List::Util 'first'; |
205 | ## no critic Prototypes |
206 | sub any (&@) { my $test = shift @_; $test->() and return 1 for @_; return 0 } |
a798dbf2 |
207 | |
9b494a7e |
208 | BEGIN { |
2adc4a42 |
209 | |
210 | # Import or create some constants from B. B doesn't provide |
211 | # everything I need so some things like OPpCONST_BARE are defined |
212 | # here. |
9b494a7e |
213 | for my $sym ( qw( begin_av check_av init_av end_av ), |
214 | [ 'OPpCONST_BARE' => 64 ] ) |
215 | { |
216 | my $val; |
217 | ( $sym, $val ) = @$sym if ref $sym; |
218 | |
2adc4a42 |
219 | if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) { |
9b494a7e |
220 | B->import($sym); |
221 | } |
222 | else { |
223 | require constant; |
224 | constant->import( $sym => $val ); |
225 | } |
226 | } |
227 | } |
228 | |
229 | my $file = "unknown"; # shadows current filename |
230 | my $line = 0; # shadows current line number |
231 | my $curstash = "main"; # shadows current stash |
232 | my $curcv; # shadows current B::CV for pad lookups |
a798dbf2 |
233 | |
9b494a7e |
234 | sub file {$file} |
235 | sub line {$line} |
236 | sub curstash {$curstash} |
237 | sub curcv {$curcv} |
ca0b1549 |
238 | |
a798dbf2 |
239 | # Lint checks |
240 | my %check; |
241 | my %implies_ok_context; |
9b494a7e |
242 | |
2adc4a42 |
243 | map( $implies_ok_context{$_}++, |
244 | qw(scalar av2arylen aelem aslice helem hslice |
245 | keys values hslice defined undef delete) ); |
a798dbf2 |
246 | |
247 | # Lint checks turned on by default |
2adc4a42 |
248 | my @default_checks |
249 | = qw(context magic_diamond undefined_subs regexp_variables); |
a798dbf2 |
250 | |
251 | my %valid_check; |
9b494a7e |
252 | |
a798dbf2 |
253 | # All valid checks |
2adc4a42 |
254 | for my $check ( |
255 | qw(context implicit_read implicit_write dollar_underscore |
256 | private_names bare_subs undefined_subs regexp_variables |
257 | magic_diamond ) |
258 | ) |
259 | { |
260 | $valid_check{$check} = __PACKAGE__; |
a798dbf2 |
261 | } |
262 | |
263 | # Debugging options |
264 | my ($debug_op); |
265 | |
9b494a7e |
266 | my %done_cv; # used to mark which subs have already been linted |
267 | my @extra_packages; # Lint checks mainline code and all subs which are |
268 | # in main:: or in one of these packages. |
a798dbf2 |
269 | |
270 | sub warning { |
9b494a7e |
271 | my $format = ( @_ < 2 ) ? "%s" : shift @_; |
272 | warn sprintf( "$format at %s line %d\n", @_, $file, $line ); |
2adc4a42 |
273 | return undef; ## no critic undef |
a798dbf2 |
274 | } |
275 | |
276 | # This gimme can't cope with context that's only determined |
277 | # at runtime via dowantarray(). |
278 | sub gimme { |
9b494a7e |
279 | my $op = shift @_; |
a798dbf2 |
280 | my $flags = $op->flags; |
9b494a7e |
281 | if ( $flags & OPf_WANT ) { |
282 | return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 ); |
a798dbf2 |
283 | } |
2adc4a42 |
284 | return undef; ## no critic undef |
a798dbf2 |
285 | } |
286 | |
2adc4a42 |
287 | my @plugins = __PACKAGE__->plugins; |
ca0b1549 |
288 | |
9b494a7e |
289 | sub inside_grepmap { |
290 | |
291 | # A boolean function to be used while inside a B::walkoptree_slow |
292 | # call. If we are in the EXPR part of C<grep EXPR, ...> or C<grep |
293 | # { EXPR } ...>, this returns true. |
2adc4a42 |
294 | return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() }; |
9b494a7e |
295 | } |
296 | |
297 | sub inside_foreach_modifier { |
298 | |
2adc4a42 |
299 | # TODO: use any() |
300 | |
9b494a7e |
301 | # A boolean function to be used while inside a B::walkoptree_slow |
302 | # call. If we are in the EXPR part of C<EXPR foreach ...> this |
303 | # returns true. |
304 | for my $ancestor ( @{ parents() } ) { |
305 | next unless $ancestor->name eq 'leaveloop'; |
306 | |
307 | my $first = $ancestor->first; |
308 | next unless $first->name eq 'enteriter'; |
309 | |
310 | next if $first->redoop->name =~ m/\A(?:next|db|set)state\z/xms; |
311 | |
312 | return 1; |
313 | } |
314 | return 0; |
315 | } |
316 | |
317 | for ( |
318 | [qw[ B::PADOP::gv_harder gv padix]], |
319 | [qw[ B::SVOP::sv_harder sv targ]], |
320 | [qw[ B::SVOP::gv_harder gv padix]] |
321 | ) |
322 | { |
323 | |
324 | # I'm generating some functions here because they're mostly |
325 | # similar. It's all for compatibility with threaded |
326 | # perl. Perhaps... this code should inspect $Config{usethreads} |
327 | # and generate a *specific* function. I'm leaving it generic for |
328 | # the moment. |
329 | # |
330 | # In threaded perl SVs and GVs aren't used directly in the optrees |
331 | # like they are in non-threaded perls. The ops that would use a SV |
332 | # or GV keep an index into the subroutine's scratchpad. I'm |
333 | # currently ignoring $cv->DEPTH and that might be at my peril. |
334 | |
335 | my ( $subname, $attr, $pad_attr ) = @$_; |
2adc4a42 |
336 | my $target = do { ## no critic strict |
337 | no strict 'refs'; |
338 | \*$subname; |
339 | }; |
9b494a7e |
340 | *$target = sub { |
341 | my ($op) = @_; |
342 | |
343 | my $elt; |
344 | if ( not $op->isa('B::PADOP') ) { |
345 | $elt = $op->$attr; |
346 | } |
2adc4a42 |
347 | return $elt if eval { $elt->isa('B::SV') }; |
9b494a7e |
348 | |
349 | my $ix = $op->$pad_attr; |
350 | my @entire_pad = $curcv->PADLIST->ARRAY; |
351 | my @elts = map +( $_->ARRAY )[$ix], @entire_pad; |
2adc4a42 |
352 | ($elt) = first { |
353 | eval { $_->isa('B::SV') } ? $_ : (); |
c97a6147 |
354 | } |
355 | @elts[ 0, reverse 1 .. $#elts ]; |
9b494a7e |
356 | return $elt; |
357 | }; |
358 | } |
359 | |
ca0b1549 |
360 | sub B::OP::lint { |
9b494a7e |
361 | my ($op) = @_; |
362 | |
363 | # This is a fallback ->lint for all the ops where I haven't |
364 | # defined something more specific. Nothing happens here. |
365 | |
366 | # Call all registered plugins |
ca0b1549 |
367 | my $m; |
9b494a7e |
368 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
369 | return; |
370 | } |
fa75652c |
371 | |
a798dbf2 |
372 | sub B::COP::lint { |
9b494a7e |
373 | my ($op) = @_; |
374 | |
375 | # nextstate ops sit between statements. Whenever I see one I |
376 | # update the current info on file, line, and stash. This code also |
377 | # updates it when it sees a dbstate or setstate op. I have no idea |
378 | # what those are but having seen them mentioned together in other |
379 | # parts of the perl I think they're kind of equivalent. |
380 | if ( $op->name =~ m/\A(?:next|db|set)state\z/ ) { |
381 | $file = $op->file; |
382 | $line = $op->line; |
383 | $curstash = $op->stash->NAME; |
a798dbf2 |
384 | } |
ca0b1549 |
385 | |
9b494a7e |
386 | # Call all registered plugins |
ca0b1549 |
387 | my $m; |
9b494a7e |
388 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
389 | return; |
a798dbf2 |
390 | } |
391 | |
392 | sub B::UNOP::lint { |
9b494a7e |
393 | my ($op) = @_; |
394 | |
3f872cb9 |
395 | my $opname = $op->name; |
9b494a7e |
396 | |
397 | CONTEXT: { |
398 | |
399 | # Check arrays and hashes in scalar or void context where |
400 | # scalar() hasn't been used. |
401 | |
402 | next |
403 | unless $check{context} |
404 | and $opname =~ m/\Arv2[ah]v\z/xms |
405 | and not gimme($op); |
406 | |
407 | my ( $parent, $gparent ) = @{ parents() }[ 0, 1 ]; |
408 | my $pname = $parent->name; |
409 | |
410 | next if $implies_ok_context{$pname}; |
411 | |
412 | # Three special cases to deal with: "foreach (@foo)", "delete |
413 | # $a{$b}", and "exists $a{$b}" null out the parent so we have to |
414 | # check for a parent of pp_null and a grandparent of |
415 | # pp_enteriter, pp_delete, pp_exists |
416 | |
417 | next |
418 | if $pname eq "null" |
419 | and $gparent->name =~ m/\A(?:delete|enteriter|exists)\z/xms; |
420 | |
421 | # our( @bar ); would also trigger this error so I exclude |
422 | # that. |
423 | next |
424 | if $op->private & OPpOUR_INTRO |
425 | and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID; |
426 | |
427 | warning 'Implicit scalar context for %s in %s', |
428 | $opname eq "rv2av" ? "array" : "hash", $parent->desc; |
a798dbf2 |
429 | } |
9b494a7e |
430 | |
431 | PRIVATE_NAMES: { |
432 | |
433 | # Looks for calls to methods with names that begin with _ and |
434 | # that aren't visible within the current package. Maybe this |
435 | # should look at @ISA. |
436 | next |
437 | unless $check{private_names} |
438 | and $opname =~ m/\Amethod/xms; |
439 | |
440 | my $methop = $op->first; |
441 | next unless $methop->name eq "const"; |
442 | |
443 | my $method = $methop->sv_harder->PV; |
444 | next |
445 | unless $method =~ m/\A_/xms |
446 | and not defined &{"$curstash\::$method"}; |
447 | |
448 | warning q[Illegal reference to private method name '%s'], $method; |
a798dbf2 |
449 | } |
ca0b1549 |
450 | |
9b494a7e |
451 | # Call all registered plugins |
ca0b1549 |
452 | my $m; |
9b494a7e |
453 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
454 | return; |
a798dbf2 |
455 | } |
456 | |
457 | sub B::PMOP::lint { |
9b494a7e |
458 | my ($op) = @_; |
459 | |
460 | IMPLICIT_READ: { |
461 | |
462 | # Look for /.../ that doesn't use =~ to bind to something. |
463 | next |
464 | unless $check{implicit_read} |
465 | and $op->name eq "match" |
466 | and not( $op->flags & OPf_STACKED |
467 | or inside_grepmap() ); |
468 | warning 'Implicit match on $_'; |
a798dbf2 |
469 | } |
9b494a7e |
470 | |
471 | IMPLICIT_WRITE: { |
472 | |
473 | # Look for s/.../.../ that doesn't use =~ to bind to |
474 | # something. |
475 | next |
476 | unless $check{implicit_write} |
477 | and $op->name eq "subst" |
478 | and not $op->flags & OPf_STACKED; |
479 | warning 'Implicit substitution on $_'; |
a798dbf2 |
480 | } |
ca0b1549 |
481 | |
9b494a7e |
482 | # Call all registered plugins |
ca0b1549 |
483 | my $m; |
9b494a7e |
484 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
485 | return; |
a798dbf2 |
486 | } |
487 | |
488 | sub B::LOOP::lint { |
9b494a7e |
489 | my ($op) = @_; |
490 | |
491 | IMPLICIT_FOO: { |
492 | |
493 | # Look for C<for ( ... )>. |
494 | next |
495 | unless ( $check{implicit_read} or $check{implicit_write} ) |
496 | and $op->name eq "enteriter"; |
497 | |
498 | my $last = $op->last; |
499 | next |
500 | unless $last->name eq "gv" |
501 | and $last->gv_harder->NAME eq "_" |
502 | and $op->redoop->name =~ m/\A(?:next|db|set)state\z/xms; |
503 | |
504 | warning 'Implicit use of $_ in foreach'; |
a798dbf2 |
505 | } |
9b494a7e |
506 | |
507 | # Call all registered plugins |
ca0b1549 |
508 | my $m; |
9b494a7e |
509 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
510 | return; |
a798dbf2 |
511 | } |
512 | |
9b494a7e |
513 | # In threaded vs non-threaded perls you'll find that threaded perls |
514 | # use PADOP in place of SVOPs so they can do lookups into the |
515 | # scratchpad to find things. I suppose this is so a optree can be |
516 | # shared between threads and all symbol table muckery will just get |
517 | # written to a scratchpad. |
c97a6147 |
518 | *B::PADOP::lint = *B::PADOP::lint = \&B::SVOP::lint; |
2e9e4ed7 |
519 | |
7934575e |
520 | sub B::SVOP::lint { |
9b494a7e |
521 | my ($op) = @_; |
522 | |
523 | MAGIC_DIAMOND: { |
524 | next |
525 | unless $check{magic_diamond} |
526 | and parents()->[0]->name eq 'readline' |
527 | and $op->gv_harder->NAME eq 'ARGV'; |
528 | |
529 | warning 'Use of <>'; |
40f1df11 |
530 | } |
9b494a7e |
531 | |
532 | BARE_SUBS: { |
533 | next |
534 | unless $check{bare_subs} |
535 | and $op->name eq 'const' |
536 | and $op->private & OPpCONST_BARE; |
537 | |
538 | my $sv = $op->sv_harder; |
539 | next unless $sv->FLAGS & SVf_POK; |
540 | |
541 | my $sub = $sv->PV; |
542 | my $subname = "$curstash\::$sub"; |
543 | |
544 | # I want to skip over things that were declared with the |
545 | # constant pragma. Well... sometimes. Hmm. I want to ignore |
546 | # C<<use constant FOO => ...>> but warn on C<<FOO => ...>> |
547 | # later. The former is typical declaration syntax and the |
548 | # latter would be an error. |
549 | # |
550 | # Skipping over both could be handled by looking if |
551 | # $constant::declared{$subname} is true. |
552 | |
553 | # Check that it's a function. |
554 | next |
555 | unless exists &{"$curstash\::$sub"}; |
556 | |
557 | warning q[Bare sub name '%s' interpreted as string], $sub; |
558 | } |
559 | |
560 | PRIVATE_NAMES: { |
561 | next unless $check{private_names}; |
562 | |
563 | my $opname = $op->name; |
564 | if ( $opname =~ m/\Agv(?:sv)?\z/xms ) { |
565 | |
566 | # Looks for uses of variables and stuff that are named |
567 | # private and we're not in the same package. |
568 | my $gv = $op->gv_harder; |
569 | my $name = $gv->NAME; |
570 | next |
571 | unless $name =~ m/\A_./xms |
572 | and $gv->STASH->NAME ne $curstash; |
573 | |
574 | warning q[Illegal reference to private name '%s'], $name; |
575 | } |
576 | elsif ( $opname eq "method_named" ) { |
577 | my $method = $op->sv_harder->PV; |
578 | next unless $method =~ m/\A_./xms; |
579 | |
580 | warning q[Illegal reference to private method name '%s'], $method; |
581 | } |
a798dbf2 |
582 | } |
9b494a7e |
583 | |
584 | DOLLAR_UNDERSCORE: { |
585 | |
586 | # Warn on uses of $_ with a few exceptions. I'm not warning on |
587 | # $_ inside grep, map, or statement modifer foreach because |
588 | # they localize $_ and it'd be impossible to use these |
589 | # features without getting warnings. |
590 | |
591 | next |
592 | unless $check{dollar_underscore} |
593 | and $op->name eq "gvsv" |
594 | and $op->gv_harder->NAME eq "_" |
595 | and not( inside_grepmap |
596 | or inside_foreach_modifier ); |
597 | |
598 | warning 'Use of $_'; |
a798dbf2 |
599 | } |
9b494a7e |
600 | |
601 | REGEXP_VARIABLES: { |
602 | |
603 | # Look for any uses of $`, $&, or $'. |
604 | next |
605 | unless $check{regexp_variables} |
606 | and $op->name eq "gvsv"; |
607 | |
608 | my $name = $op->gv_harder->NAME; |
609 | next unless $name =~ m/\A[\&\'\`]\z/xms; |
610 | |
611 | warning 'Use of regexp variable $%s', $name; |
a798dbf2 |
612 | } |
9b494a7e |
613 | |
614 | UNDEFINED_SUBS: { |
615 | |
616 | # Look for calls to functions that either don't exist or don't |
617 | # have a definition. |
618 | next |
619 | unless $check{undefined_subs} |
620 | and $op->name eq "gv" |
621 | and $op->next->name eq "entersub"; |
622 | |
623 | my $gv = $op->gv_harder; |
624 | my $subname = $gv->STASH->NAME . "::" . $gv->NAME; |
625 | |
2adc4a42 |
626 | no strict 'refs'; ## no critic strict |
9b494a7e |
627 | if ( not exists &$subname ) { |
628 | $subname =~ s/\Amain:://; |
629 | warning q[Nonexistant subroutine '%s' called], $subname; |
630 | } |
631 | elsif ( not defined &$subname ) { |
632 | $subname =~ s/\A\&?main:://; |
633 | warning q[Undefined subroutine '%s' called], $subname; |
634 | } |
a798dbf2 |
635 | } |
9b494a7e |
636 | |
637 | # Call all registered plugins |
ca0b1549 |
638 | my $m; |
9b494a7e |
639 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
640 | return; |
a798dbf2 |
641 | } |
642 | |
643 | sub B::GV::lintcv { |
2adc4a42 |
644 | |
645 | # Example: B::svref_2object( \ *A::Glob )->lintcv |
646 | |
9b494a7e |
647 | my $gv = shift @_; |
a798dbf2 |
648 | my $cv = $gv->CV; |
9b494a7e |
649 | return unless $cv->can('lintcv'); |
650 | $cv->lintcv; |
651 | return; |
652 | } |
653 | |
654 | sub B::CV::lintcv { |
655 | |
2adc4a42 |
656 | # Example: B::svref_2object( \ &foo )->lintcv |
657 | |
9b494a7e |
658 | # Write to the *global* $ |
659 | $curcv = shift @_; |
660 | |
a798dbf2 |
661 | #warn sprintf("lintcv: %s::%s (done=%d)\n", |
9b494a7e |
662 | # $gv->STASH->NAME, $gv->NAME, $done_cv{$$curcv});#debug |
663 | return unless ref($curcv) and $$curcv and not $done_cv{$$curcv}++; |
664 | my $root = $curcv->ROOT; |
665 | |
a798dbf2 |
666 | #warn " root = $root (0x$$root)\n";#debug |
9b494a7e |
667 | walkoptree_slow( $root, "lint" ) if $$root; |
668 | return; |
a798dbf2 |
669 | } |
670 | |
671 | sub do_lint { |
672 | my %search_pack; |
9b494a7e |
673 | |
674 | # Copy to the global $curcv for use in pad lookups. |
675 | $curcv = main_cv; |
676 | walkoptree_slow( main_root, "lint" ) if ${ main_root() }; |
677 | |
678 | # Do all the miscellaneous non-sub blocks. |
679 | for my $av ( begin_av, init_av, check_av, end_av ) { |
2adc4a42 |
680 | next unless eval { $av->isa('B::AV') }; |
9b494a7e |
681 | for my $cv ( $av->ARRAY ) { |
682 | next unless ref($cv) and $cv->FILE eq $0; |
683 | $cv->lintcv; |
684 | } |
a798dbf2 |
685 | } |
686 | |
9b494a7e |
687 | walksymtable( |
688 | \%main::, |
689 | sub { |
690 | if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv } |
691 | }, |
692 | sub {1} |
693 | ); |
694 | return; |
a798dbf2 |
695 | } |
696 | |
697 | sub compile { |
698 | my @options = @_; |
9b494a7e |
699 | |
a798dbf2 |
700 | # Turn on default lint checks |
9b494a7e |
701 | for my $opt (@default_checks) { |
702 | $check{$opt} = 1; |
a798dbf2 |
703 | } |
9b494a7e |
704 | |
705 | OPTION: |
706 | while ( my $option = shift @options ) { |
707 | my ( $opt, $arg ); |
708 | unless ( ( $opt, $arg ) = $option =~ m/\A-(.)(.*)/xms ) { |
709 | unshift @options, $option; |
710 | last OPTION; |
711 | } |
712 | |
713 | if ( $opt eq "-" && $arg eq "-" ) { |
714 | shift @options; |
715 | last OPTION; |
716 | } |
717 | elsif ( $opt eq "D" ) { |
a798dbf2 |
718 | $arg ||= shift @options; |
9b494a7e |
719 | foreach my $arg ( split //, $arg ) { |
720 | if ( $arg eq "o" ) { |
721 | B->debug(1); |
722 | } |
723 | elsif ( $arg eq "O" ) { |
724 | $debug_op = 1; |
725 | } |
726 | } |
727 | } |
728 | elsif ( $opt eq "u" ) { |
729 | $arg ||= shift @options; |
730 | push @extra_packages, $arg; |
731 | } |
a798dbf2 |
732 | } |
9b494a7e |
733 | |
734 | foreach my $opt ( @default_checks, @options ) { |
735 | $opt =~ tr/-/_/; |
736 | if ( $opt eq "all" ) { |
2adc4a42 |
737 | %check = %valid_check; |
9b494a7e |
738 | } |
739 | elsif ( $opt eq "none" ) { |
740 | %check = (); |
741 | } |
742 | else { |
743 | if ( $opt =~ s/\Ano_//xms ) { |
744 | $check{$opt} = 0; |
745 | } |
746 | else { |
747 | $check{$opt} = 1; |
748 | } |
2adc4a42 |
749 | carp "No such check: $opt" |
750 | unless defined $valid_check{$opt}; |
9b494a7e |
751 | } |
a798dbf2 |
752 | } |
9b494a7e |
753 | |
754 | # Remaining arguments are things to check. So why aren't I |
755 | # capturing them or something? I don't know. |
fa75652c |
756 | |
a798dbf2 |
757 | return \&do_lint; |
758 | } |
759 | |
ca0b1549 |
760 | sub register_plugin { |
761 | my ( undef, $plugin, $new_checks ) = @_; |
fa75652c |
762 | |
2adc4a42 |
763 | # Allow the user to be lazy and not give us a name. |
764 | $plugin = caller unless defined $plugin; |
765 | |
766 | # Register the plugin's named checks, if any. |
767 | for my $check ( eval {@$new_checks} ) { |
768 | if ( not defined $check ) { |
769 | carp 'Undefined value in checks.'; |
770 | next; |
771 | } |
772 | if ( exists $valid_check{$check} ) { |
773 | carp |
774 | "$check is already registered as a $valid_check{$check} feature."; |
775 | next; |
776 | } |
777 | |
778 | $valid_check{$check} = $plugin; |
ca0b1549 |
779 | } |
fa75652c |
780 | |
2adc4a42 |
781 | # Register a non-Module::Pluggable loaded module. @plugins already |
782 | # contains whatever M::P found on disk. The user might load a |
783 | # plugin manually from some arbitrary namespace and ask for it to |
784 | # be registered. |
785 | if ( not any { $_ eq $plugin } @plugins ) { |
786 | push @plugins, $plugin; |
787 | } |
fa75652c |
788 | |
ca0b1549 |
789 | return; |
790 | } |
791 | |
a798dbf2 |
792 | 1; |