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