Commit | Line | Data |
a798dbf2 |
1 | package B::Lint; |
2 | |
2adc4a42 |
3 | our $VERSION = '1.09'; ## 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 | |
188 | =cut |
189 | |
190 | use strict; |
9b494a7e |
191 | use B qw( walkoptree_slow |
192 | main_root main_cv walksymtable parents |
193 | OPpOUR_INTRO |
194 | OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED SVf_POK ); |
2adc4a42 |
195 | use Carp 'carp'; |
196 | |
197 | # The current M::P doesn't know about .pmc files. |
198 | use Module::Pluggable ( require => 1 ); |
199 | |
200 | use List::Util 'first'; |
201 | ## no critic Prototypes |
202 | sub any (&@) { my $test = shift @_; $test->() and return 1 for @_; return 0 } |
a798dbf2 |
203 | |
9b494a7e |
204 | BEGIN { |
2adc4a42 |
205 | |
206 | # Import or create some constants from B. B doesn't provide |
207 | # everything I need so some things like OPpCONST_BARE are defined |
208 | # here. |
9b494a7e |
209 | for my $sym ( qw( begin_av check_av init_av end_av ), |
210 | [ 'OPpCONST_BARE' => 64 ] ) |
211 | { |
212 | my $val; |
213 | ( $sym, $val ) = @$sym if ref $sym; |
214 | |
2adc4a42 |
215 | if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) { |
9b494a7e |
216 | B->import($sym); |
217 | } |
218 | else { |
219 | require constant; |
220 | constant->import( $sym => $val ); |
221 | } |
222 | } |
223 | } |
224 | |
225 | my $file = "unknown"; # shadows current filename |
226 | my $line = 0; # shadows current line number |
227 | my $curstash = "main"; # shadows current stash |
228 | my $curcv; # shadows current B::CV for pad lookups |
a798dbf2 |
229 | |
9b494a7e |
230 | sub file {$file} |
231 | sub line {$line} |
232 | sub curstash {$curstash} |
233 | sub curcv {$curcv} |
ca0b1549 |
234 | |
a798dbf2 |
235 | # Lint checks |
236 | my %check; |
237 | my %implies_ok_context; |
9b494a7e |
238 | |
2adc4a42 |
239 | map( $implies_ok_context{$_}++, |
240 | qw(scalar av2arylen aelem aslice helem hslice |
241 | keys values hslice defined undef delete) ); |
a798dbf2 |
242 | |
243 | # Lint checks turned on by default |
2adc4a42 |
244 | my @default_checks |
245 | = qw(context magic_diamond undefined_subs regexp_variables); |
a798dbf2 |
246 | |
247 | my %valid_check; |
9b494a7e |
248 | |
a798dbf2 |
249 | # All valid checks |
2adc4a42 |
250 | for my $check ( |
251 | qw(context implicit_read implicit_write dollar_underscore |
252 | private_names bare_subs undefined_subs regexp_variables |
253 | magic_diamond ) |
254 | ) |
255 | { |
256 | $valid_check{$check} = __PACKAGE__; |
a798dbf2 |
257 | } |
258 | |
259 | # Debugging options |
260 | my ($debug_op); |
261 | |
9b494a7e |
262 | my %done_cv; # used to mark which subs have already been linted |
263 | my @extra_packages; # Lint checks mainline code and all subs which are |
264 | # in main:: or in one of these packages. |
a798dbf2 |
265 | |
266 | sub warning { |
9b494a7e |
267 | my $format = ( @_ < 2 ) ? "%s" : shift @_; |
268 | warn sprintf( "$format at %s line %d\n", @_, $file, $line ); |
2adc4a42 |
269 | return undef; ## no critic undef |
a798dbf2 |
270 | } |
271 | |
272 | # This gimme can't cope with context that's only determined |
273 | # at runtime via dowantarray(). |
274 | sub gimme { |
9b494a7e |
275 | my $op = shift @_; |
a798dbf2 |
276 | my $flags = $op->flags; |
9b494a7e |
277 | if ( $flags & OPf_WANT ) { |
278 | return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 ); |
a798dbf2 |
279 | } |
2adc4a42 |
280 | return undef; ## no critic undef |
a798dbf2 |
281 | } |
282 | |
2adc4a42 |
283 | my @plugins = __PACKAGE__->plugins; |
ca0b1549 |
284 | |
9b494a7e |
285 | sub inside_grepmap { |
286 | |
287 | # A boolean function to be used while inside a B::walkoptree_slow |
288 | # call. If we are in the EXPR part of C<grep EXPR, ...> or C<grep |
289 | # { EXPR } ...>, this returns true. |
2adc4a42 |
290 | return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() }; |
9b494a7e |
291 | } |
292 | |
293 | sub inside_foreach_modifier { |
294 | |
2adc4a42 |
295 | # TODO: use any() |
296 | |
9b494a7e |
297 | # A boolean function to be used while inside a B::walkoptree_slow |
298 | # call. If we are in the EXPR part of C<EXPR foreach ...> this |
299 | # returns true. |
300 | for my $ancestor ( @{ parents() } ) { |
301 | next unless $ancestor->name eq 'leaveloop'; |
302 | |
303 | my $first = $ancestor->first; |
304 | next unless $first->name eq 'enteriter'; |
305 | |
306 | next if $first->redoop->name =~ m/\A(?:next|db|set)state\z/xms; |
307 | |
308 | return 1; |
309 | } |
310 | return 0; |
311 | } |
312 | |
313 | for ( |
314 | [qw[ B::PADOP::gv_harder gv padix]], |
315 | [qw[ B::SVOP::sv_harder sv targ]], |
316 | [qw[ B::SVOP::gv_harder gv padix]] |
317 | ) |
318 | { |
319 | |
320 | # I'm generating some functions here because they're mostly |
321 | # similar. It's all for compatibility with threaded |
322 | # perl. Perhaps... this code should inspect $Config{usethreads} |
323 | # and generate a *specific* function. I'm leaving it generic for |
324 | # the moment. |
325 | # |
326 | # In threaded perl SVs and GVs aren't used directly in the optrees |
327 | # like they are in non-threaded perls. The ops that would use a SV |
328 | # or GV keep an index into the subroutine's scratchpad. I'm |
329 | # currently ignoring $cv->DEPTH and that might be at my peril. |
330 | |
331 | my ( $subname, $attr, $pad_attr ) = @$_; |
2adc4a42 |
332 | my $target = do { ## no critic strict |
333 | no strict 'refs'; |
334 | \*$subname; |
335 | }; |
9b494a7e |
336 | *$target = sub { |
337 | my ($op) = @_; |
338 | |
339 | my $elt; |
340 | if ( not $op->isa('B::PADOP') ) { |
341 | $elt = $op->$attr; |
342 | } |
2adc4a42 |
343 | return $elt if eval { $elt->isa('B::SV') }; |
9b494a7e |
344 | |
345 | my $ix = $op->$pad_attr; |
346 | my @entire_pad = $curcv->PADLIST->ARRAY; |
347 | my @elts = map +( $_->ARRAY )[$ix], @entire_pad; |
2adc4a42 |
348 | ($elt) = first { |
349 | eval { $_->isa('B::SV') } ? $_ : (); |
350 | } |
9b494a7e |
351 | @elts[ 0, reverse 1 .. $#elts ]; |
352 | return $elt; |
353 | }; |
354 | } |
355 | |
ca0b1549 |
356 | sub B::OP::lint { |
9b494a7e |
357 | my ($op) = @_; |
358 | |
359 | # This is a fallback ->lint for all the ops where I haven't |
360 | # defined something more specific. Nothing happens here. |
361 | |
362 | # Call all registered plugins |
ca0b1549 |
363 | my $m; |
9b494a7e |
364 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
365 | return; |
366 | } |
fa75652c |
367 | |
a798dbf2 |
368 | sub B::COP::lint { |
9b494a7e |
369 | my ($op) = @_; |
370 | |
371 | # nextstate ops sit between statements. Whenever I see one I |
372 | # update the current info on file, line, and stash. This code also |
373 | # updates it when it sees a dbstate or setstate op. I have no idea |
374 | # what those are but having seen them mentioned together in other |
375 | # parts of the perl I think they're kind of equivalent. |
376 | if ( $op->name =~ m/\A(?:next|db|set)state\z/ ) { |
377 | $file = $op->file; |
378 | $line = $op->line; |
379 | $curstash = $op->stash->NAME; |
a798dbf2 |
380 | } |
ca0b1549 |
381 | |
9b494a7e |
382 | # Call all registered plugins |
ca0b1549 |
383 | my $m; |
9b494a7e |
384 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
385 | return; |
a798dbf2 |
386 | } |
387 | |
388 | sub B::UNOP::lint { |
9b494a7e |
389 | my ($op) = @_; |
390 | |
3f872cb9 |
391 | my $opname = $op->name; |
9b494a7e |
392 | |
393 | CONTEXT: { |
394 | |
395 | # Check arrays and hashes in scalar or void context where |
396 | # scalar() hasn't been used. |
397 | |
398 | next |
399 | unless $check{context} |
400 | and $opname =~ m/\Arv2[ah]v\z/xms |
401 | and not gimme($op); |
402 | |
403 | my ( $parent, $gparent ) = @{ parents() }[ 0, 1 ]; |
404 | my $pname = $parent->name; |
405 | |
406 | next if $implies_ok_context{$pname}; |
407 | |
408 | # Three special cases to deal with: "foreach (@foo)", "delete |
409 | # $a{$b}", and "exists $a{$b}" null out the parent so we have to |
410 | # check for a parent of pp_null and a grandparent of |
411 | # pp_enteriter, pp_delete, pp_exists |
412 | |
413 | next |
414 | if $pname eq "null" |
415 | and $gparent->name =~ m/\A(?:delete|enteriter|exists)\z/xms; |
416 | |
417 | # our( @bar ); would also trigger this error so I exclude |
418 | # that. |
419 | next |
420 | if $op->private & OPpOUR_INTRO |
421 | and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID; |
422 | |
423 | warning 'Implicit scalar context for %s in %s', |
424 | $opname eq "rv2av" ? "array" : "hash", $parent->desc; |
a798dbf2 |
425 | } |
9b494a7e |
426 | |
427 | PRIVATE_NAMES: { |
428 | |
429 | # Looks for calls to methods with names that begin with _ and |
430 | # that aren't visible within the current package. Maybe this |
431 | # should look at @ISA. |
432 | next |
433 | unless $check{private_names} |
434 | and $opname =~ m/\Amethod/xms; |
435 | |
436 | my $methop = $op->first; |
437 | next unless $methop->name eq "const"; |
438 | |
439 | my $method = $methop->sv_harder->PV; |
440 | next |
441 | unless $method =~ m/\A_/xms |
442 | and not defined &{"$curstash\::$method"}; |
443 | |
444 | warning q[Illegal reference to private method name '%s'], $method; |
a798dbf2 |
445 | } |
ca0b1549 |
446 | |
9b494a7e |
447 | # Call all registered plugins |
ca0b1549 |
448 | my $m; |
9b494a7e |
449 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
450 | return; |
a798dbf2 |
451 | } |
452 | |
453 | sub B::PMOP::lint { |
9b494a7e |
454 | my ($op) = @_; |
455 | |
456 | IMPLICIT_READ: { |
457 | |
458 | # Look for /.../ that doesn't use =~ to bind to something. |
459 | next |
460 | unless $check{implicit_read} |
461 | and $op->name eq "match" |
462 | and not( $op->flags & OPf_STACKED |
463 | or inside_grepmap() ); |
464 | warning 'Implicit match on $_'; |
a798dbf2 |
465 | } |
9b494a7e |
466 | |
467 | IMPLICIT_WRITE: { |
468 | |
469 | # Look for s/.../.../ that doesn't use =~ to bind to |
470 | # something. |
471 | next |
472 | unless $check{implicit_write} |
473 | and $op->name eq "subst" |
474 | and not $op->flags & OPf_STACKED; |
475 | warning 'Implicit substitution on $_'; |
a798dbf2 |
476 | } |
ca0b1549 |
477 | |
9b494a7e |
478 | # Call all registered plugins |
ca0b1549 |
479 | my $m; |
9b494a7e |
480 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
481 | return; |
a798dbf2 |
482 | } |
483 | |
484 | sub B::LOOP::lint { |
9b494a7e |
485 | my ($op) = @_; |
486 | |
487 | IMPLICIT_FOO: { |
488 | |
489 | # Look for C<for ( ... )>. |
490 | next |
491 | unless ( $check{implicit_read} or $check{implicit_write} ) |
492 | and $op->name eq "enteriter"; |
493 | |
494 | my $last = $op->last; |
495 | next |
496 | unless $last->name eq "gv" |
497 | and $last->gv_harder->NAME eq "_" |
498 | and $op->redoop->name =~ m/\A(?:next|db|set)state\z/xms; |
499 | |
500 | warning 'Implicit use of $_ in foreach'; |
a798dbf2 |
501 | } |
9b494a7e |
502 | |
503 | # Call all registered plugins |
ca0b1549 |
504 | my $m; |
9b494a7e |
505 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
506 | return; |
a798dbf2 |
507 | } |
508 | |
9b494a7e |
509 | # In threaded vs non-threaded perls you'll find that threaded perls |
510 | # use PADOP in place of SVOPs so they can do lookups into the |
511 | # scratchpad to find things. I suppose this is so a optree can be |
512 | # shared between threads and all symbol table muckery will just get |
513 | # written to a scratchpad. |
514 | *B::PADOP::lint = \&B::SVOP::lint; |
2e9e4ed7 |
515 | |
7934575e |
516 | sub B::SVOP::lint { |
9b494a7e |
517 | my ($op) = @_; |
518 | |
519 | MAGIC_DIAMOND: { |
520 | next |
521 | unless $check{magic_diamond} |
522 | and parents()->[0]->name eq 'readline' |
523 | and $op->gv_harder->NAME eq 'ARGV'; |
524 | |
525 | warning 'Use of <>'; |
40f1df11 |
526 | } |
9b494a7e |
527 | |
528 | BARE_SUBS: { |
529 | next |
530 | unless $check{bare_subs} |
531 | and $op->name eq 'const' |
532 | and $op->private & OPpCONST_BARE; |
533 | |
534 | my $sv = $op->sv_harder; |
535 | next unless $sv->FLAGS & SVf_POK; |
536 | |
537 | my $sub = $sv->PV; |
538 | my $subname = "$curstash\::$sub"; |
539 | |
540 | # I want to skip over things that were declared with the |
541 | # constant pragma. Well... sometimes. Hmm. I want to ignore |
542 | # C<<use constant FOO => ...>> but warn on C<<FOO => ...>> |
543 | # later. The former is typical declaration syntax and the |
544 | # latter would be an error. |
545 | # |
546 | # Skipping over both could be handled by looking if |
547 | # $constant::declared{$subname} is true. |
548 | |
549 | # Check that it's a function. |
550 | next |
551 | unless exists &{"$curstash\::$sub"}; |
552 | |
553 | warning q[Bare sub name '%s' interpreted as string], $sub; |
554 | } |
555 | |
556 | PRIVATE_NAMES: { |
557 | next unless $check{private_names}; |
558 | |
559 | my $opname = $op->name; |
560 | if ( $opname =~ m/\Agv(?:sv)?\z/xms ) { |
561 | |
562 | # Looks for uses of variables and stuff that are named |
563 | # private and we're not in the same package. |
564 | my $gv = $op->gv_harder; |
565 | my $name = $gv->NAME; |
566 | next |
567 | unless $name =~ m/\A_./xms |
568 | and $gv->STASH->NAME ne $curstash; |
569 | |
570 | warning q[Illegal reference to private name '%s'], $name; |
571 | } |
572 | elsif ( $opname eq "method_named" ) { |
573 | my $method = $op->sv_harder->PV; |
574 | next unless $method =~ m/\A_./xms; |
575 | |
576 | warning q[Illegal reference to private method name '%s'], $method; |
577 | } |
a798dbf2 |
578 | } |
9b494a7e |
579 | |
580 | DOLLAR_UNDERSCORE: { |
581 | |
582 | # Warn on uses of $_ with a few exceptions. I'm not warning on |
583 | # $_ inside grep, map, or statement modifer foreach because |
584 | # they localize $_ and it'd be impossible to use these |
585 | # features without getting warnings. |
586 | |
587 | next |
588 | unless $check{dollar_underscore} |
589 | and $op->name eq "gvsv" |
590 | and $op->gv_harder->NAME eq "_" |
591 | and not( inside_grepmap |
592 | or inside_foreach_modifier ); |
593 | |
594 | warning 'Use of $_'; |
a798dbf2 |
595 | } |
9b494a7e |
596 | |
597 | REGEXP_VARIABLES: { |
598 | |
599 | # Look for any uses of $`, $&, or $'. |
600 | next |
601 | unless $check{regexp_variables} |
602 | and $op->name eq "gvsv"; |
603 | |
604 | my $name = $op->gv_harder->NAME; |
605 | next unless $name =~ m/\A[\&\'\`]\z/xms; |
606 | |
607 | warning 'Use of regexp variable $%s', $name; |
a798dbf2 |
608 | } |
9b494a7e |
609 | |
610 | UNDEFINED_SUBS: { |
611 | |
612 | # Look for calls to functions that either don't exist or don't |
613 | # have a definition. |
614 | next |
615 | unless $check{undefined_subs} |
616 | and $op->name eq "gv" |
617 | and $op->next->name eq "entersub"; |
618 | |
619 | my $gv = $op->gv_harder; |
620 | my $subname = $gv->STASH->NAME . "::" . $gv->NAME; |
621 | |
2adc4a42 |
622 | no strict 'refs'; ## no critic strict |
9b494a7e |
623 | if ( not exists &$subname ) { |
624 | $subname =~ s/\Amain:://; |
625 | warning q[Nonexistant subroutine '%s' called], $subname; |
626 | } |
627 | elsif ( not defined &$subname ) { |
628 | $subname =~ s/\A\&?main:://; |
629 | warning q[Undefined subroutine '%s' called], $subname; |
630 | } |
a798dbf2 |
631 | } |
9b494a7e |
632 | |
633 | # Call all registered plugins |
ca0b1549 |
634 | my $m; |
9b494a7e |
635 | $m = $_->can('match'), $op->$m( \%check ) for @plugins; |
ca0b1549 |
636 | return; |
a798dbf2 |
637 | } |
638 | |
639 | sub B::GV::lintcv { |
2adc4a42 |
640 | |
641 | # Example: B::svref_2object( \ *A::Glob )->lintcv |
642 | |
9b494a7e |
643 | my $gv = shift @_; |
a798dbf2 |
644 | my $cv = $gv->CV; |
9b494a7e |
645 | return unless $cv->can('lintcv'); |
646 | $cv->lintcv; |
647 | return; |
648 | } |
649 | |
650 | sub B::CV::lintcv { |
651 | |
2adc4a42 |
652 | # Example: B::svref_2object( \ &foo )->lintcv |
653 | |
9b494a7e |
654 | # Write to the *global* $ |
655 | $curcv = shift @_; |
656 | |
a798dbf2 |
657 | #warn sprintf("lintcv: %s::%s (done=%d)\n", |
9b494a7e |
658 | # $gv->STASH->NAME, $gv->NAME, $done_cv{$$curcv});#debug |
659 | return unless ref($curcv) and $$curcv and not $done_cv{$$curcv}++; |
660 | my $root = $curcv->ROOT; |
661 | |
a798dbf2 |
662 | #warn " root = $root (0x$$root)\n";#debug |
9b494a7e |
663 | walkoptree_slow( $root, "lint" ) if $$root; |
664 | return; |
a798dbf2 |
665 | } |
666 | |
667 | sub do_lint { |
668 | my %search_pack; |
9b494a7e |
669 | |
670 | # Copy to the global $curcv for use in pad lookups. |
671 | $curcv = main_cv; |
672 | walkoptree_slow( main_root, "lint" ) if ${ main_root() }; |
673 | |
674 | # Do all the miscellaneous non-sub blocks. |
675 | for my $av ( begin_av, init_av, check_av, end_av ) { |
2adc4a42 |
676 | next unless eval { $av->isa('B::AV') }; |
9b494a7e |
677 | for my $cv ( $av->ARRAY ) { |
678 | next unless ref($cv) and $cv->FILE eq $0; |
679 | $cv->lintcv; |
680 | } |
a798dbf2 |
681 | } |
682 | |
9b494a7e |
683 | walksymtable( |
684 | \%main::, |
685 | sub { |
686 | if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv } |
687 | }, |
688 | sub {1} |
689 | ); |
690 | return; |
a798dbf2 |
691 | } |
692 | |
693 | sub compile { |
694 | my @options = @_; |
9b494a7e |
695 | |
a798dbf2 |
696 | # Turn on default lint checks |
9b494a7e |
697 | for my $opt (@default_checks) { |
698 | $check{$opt} = 1; |
a798dbf2 |
699 | } |
9b494a7e |
700 | |
701 | OPTION: |
702 | while ( my $option = shift @options ) { |
703 | my ( $opt, $arg ); |
704 | unless ( ( $opt, $arg ) = $option =~ m/\A-(.)(.*)/xms ) { |
705 | unshift @options, $option; |
706 | last OPTION; |
707 | } |
708 | |
709 | if ( $opt eq "-" && $arg eq "-" ) { |
710 | shift @options; |
711 | last OPTION; |
712 | } |
713 | elsif ( $opt eq "D" ) { |
a798dbf2 |
714 | $arg ||= shift @options; |
9b494a7e |
715 | foreach my $arg ( split //, $arg ) { |
716 | if ( $arg eq "o" ) { |
717 | B->debug(1); |
718 | } |
719 | elsif ( $arg eq "O" ) { |
720 | $debug_op = 1; |
721 | } |
722 | } |
723 | } |
724 | elsif ( $opt eq "u" ) { |
725 | $arg ||= shift @options; |
726 | push @extra_packages, $arg; |
727 | } |
a798dbf2 |
728 | } |
9b494a7e |
729 | |
730 | foreach my $opt ( @default_checks, @options ) { |
731 | $opt =~ tr/-/_/; |
732 | if ( $opt eq "all" ) { |
2adc4a42 |
733 | %check = %valid_check; |
9b494a7e |
734 | } |
735 | elsif ( $opt eq "none" ) { |
736 | %check = (); |
737 | } |
738 | else { |
739 | if ( $opt =~ s/\Ano_//xms ) { |
740 | $check{$opt} = 0; |
741 | } |
742 | else { |
743 | $check{$opt} = 1; |
744 | } |
2adc4a42 |
745 | carp "No such check: $opt" |
746 | unless defined $valid_check{$opt}; |
9b494a7e |
747 | } |
a798dbf2 |
748 | } |
9b494a7e |
749 | |
750 | # Remaining arguments are things to check. So why aren't I |
751 | # capturing them or something? I don't know. |
fa75652c |
752 | |
a798dbf2 |
753 | return \&do_lint; |
754 | } |
755 | |
ca0b1549 |
756 | sub register_plugin { |
757 | my ( undef, $plugin, $new_checks ) = @_; |
fa75652c |
758 | |
2adc4a42 |
759 | # Allow the user to be lazy and not give us a name. |
760 | $plugin = caller unless defined $plugin; |
761 | |
762 | # Register the plugin's named checks, if any. |
763 | for my $check ( eval {@$new_checks} ) { |
764 | if ( not defined $check ) { |
765 | carp 'Undefined value in checks.'; |
766 | next; |
767 | } |
768 | if ( exists $valid_check{$check} ) { |
769 | carp |
770 | "$check is already registered as a $valid_check{$check} feature."; |
771 | next; |
772 | } |
773 | |
774 | $valid_check{$check} = $plugin; |
ca0b1549 |
775 | } |
fa75652c |
776 | |
2adc4a42 |
777 | # Register a non-Module::Pluggable loaded module. @plugins already |
778 | # contains whatever M::P found on disk. The user might load a |
779 | # plugin manually from some arbitrary namespace and ask for it to |
780 | # be registered. |
781 | if ( not any { $_ eq $plugin } @plugins ) { |
782 | push @plugins, $plugin; |
783 | } |
fa75652c |
784 | |
ca0b1549 |
785 | return; |
786 | } |
787 | |
a798dbf2 |
788 | 1; |