This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: B::Lint changes
[perl5.git] / ext / B / B / Lint.pm
CommitLineData
a798dbf2
MB
1package B::Lint;
2
9b494a7e 3our $VERSION = '1.08';
28b605d8 4
a798dbf2
MB
5=head1 NAME
6
7B::Lint - Perl lint
8
9=head1 SYNOPSIS
10
11perl -MO=Lint[,OPTIONS] foo.pl
12
13=head1 DESCRIPTION
14
15The B::Lint module is equivalent to an extended version of the B<-w>
c00253d5 16option of B<perl>. It is named after the program F<lint> which carries
a798dbf2
MB
17out a similar process for C programs.
18
19=head1 OPTIONS AND LINT CHECKS
20
21Option words are separated by commas (not whitespace) and follow the
22usual conventions of compiler backend options. Following any options
23(indicated by a leading B<->) come lint check arguments. Each such
24argument (apart from the special B<all> and B<none> options) is a
25word representing one possible lint check (turning on that check) or
26is B<no-foo> (turning off that check). Before processing the check
27arguments, a standard list of checks is turned on. Later options
28override earlier ones. Available options are:
29
30=over 8
31
9b494a7e
JJ
32=item B<magic-diamond>
33
34Produces a warning whenever the magic C<E<lt>E<gt>> readline is
35used. Internally it uses perl's two-argument open which itself treats
36filenames with special characters specially. This could allow
37interestingly named files to have unexpected effects when reading.
38
39 % touch 'rm *|'
40 % perl -pe 1
41
42The above creates a file named C<rm *|>. When perl opens it with
43C<E<lt>E<gt>> it actually executes the shell program C<rm *>. This
44makes C<E<lt>E<gt>> dangerous to use carelessly.
45
a798dbf2
MB
46=item B<context>
47
48Produces a warning whenever an array is used in an implicit scalar
49context. For example, both of the lines
50
51 $foo = length(@bar);
52 $foo = @bar;
c00253d5 53
a798dbf2
MB
54will elicit a warning. Using an explicit B<scalar()> silences the
55warning. For example,
56
57 $foo = scalar(@bar);
58
59=item B<implicit-read> and B<implicit-write>
60
61These options produce a warning whenever an operation implicitly
62reads or (respectively) writes to one of Perl's special variables.
63For example, B<implicit-read> will warn about these:
64
65 /foo/;
66
67and B<implicit-write> will warn about these:
68
69 s/foo/bar/;
70
71Both B<implicit-read> and B<implicit-write> warn about this:
72
73 for (@a) { ... }
74
40f1df11
RGS
75=item B<bare-subs>
76
77This option warns whenever a bareword is implicitly quoted, but is also
78the name of a subroutine in the current package. Typical mistakes that it will
79trap are:
80
c00253d5
AL
81 use constant foo => 'bar';
82 @a = ( foo => 1 );
83 $b{foo} = 2;
40f1df11
RGS
84
85Neither of these will do what a naive user would expect.
86
a798dbf2
MB
87=item B<dollar-underscore>
88
c00253d5 89This option warns whenever C<$_> is used either explicitly anywhere or
a798dbf2
MB
90as the implicit argument of a B<print> statement.
91
92=item B<private-names>
93
94This option warns on each use of any variable, subroutine or
95method name that lives in a non-current package but begins with
96an underscore ("_"). Warnings aren't issued for the special case
c00253d5 97of the single character name "_" by itself (e.g. C<$_> and C<@_>).
a798dbf2
MB
98
99=item B<undefined-subs>
100
101This option warns whenever an undefined subroutine is invoked.
102This option will only catch explicitly invoked subroutines such
103as C<foo()> and not indirect invocations such as C<&$subref()>
104or C<$obj-E<gt>meth()>. Note that some programs or modules delay
105definition of subs until runtime by means of the AUTOLOAD
106mechanism.
107
108=item B<regexp-variables>
109
c00253d5
AL
110This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
111is used. Any occurrence of any of these variables in your
a798dbf2
MB
112program can slow your whole program down. See L<perlre> for
113details.
114
115=item B<all>
116
117Turn all warnings on.
118
119=item B<none>
120
121Turn all warnings off.
122
123=back
124
125=head1 NON LINT-CHECK OPTIONS
126
127=over 8
128
129=item B<-u Package>
130
131Normally, Lint only checks the main code of the program together
132with all subs defined in package main. The B<-u> option lets you
133include other package names whose subs are then checked by Lint.
134
135=back
136
ca0b1549
JJ
137=head1 EXTENDING LINT
138
139Lint can be extended by registering plugins.
140
fa75652c 141The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
ca0b1549
JJ
142adds the class C<MyPlugin> to the list of plugins. It also adds the
143list of C<@new_checks> to the list of valid checks.
144
fa75652c
RGS
145You must create a C<match( \%checks )> method in your plugin class or one
146of its parents. It will be called on every op as a regular method call
147with a hash ref of checks as its parameter.
ca0b1549 148
fa75652c 149You may not alter the %checks hash reference.
ca0b1549 150
fa75652c
RGS
151The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
152the current filename and line number.
ca0b1549 153
fa75652c
RGS
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
RGS
160 if ( $checks_href->{good_taste} ) {
161 ...
162 }
163 }
ca0b1549 164
9b494a7e
JJ
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
MB
177=head1 BUGS
178
179This is only a very preliminary version.
180
181=head1 AUTHOR
182
183Malcolm Beattie, mbeattie@sable.ox.ac.uk.
184
185=cut
186
187use strict;
9b494a7e
JJ
188use 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
JJ
193BEGIN {
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
210my $file = "unknown"; # shadows current filename
211my $line = 0; # shadows current line number
212my $curstash = "main"; # shadows current stash
213my $curcv; # shadows current B::CV for pad lookups
a798dbf2 214
9b494a7e
JJ
215sub file {$file}
216sub line {$line}
217sub curstash {$curstash}
218sub curcv {$curcv}
ca0b1549 219
a798dbf2
MB
220# Lint checks
221my %check;
222my %implies_ok_context;
9b494a7e 223
a798dbf2 224BEGIN {
9b494a7e
JJ
225 map( $implies_ok_context{$_}++,
226 qw(scalar av2arylen aelem aslice helem hslice
227 keys values hslice defined undef delete) );
a798dbf2
MB
228}
229
230# Lint checks turned on by default
231my @default_checks = qw(context);
232
233my %valid_check;
ca0b1549 234my %plugin_valid_check;
9b494a7e 235
a798dbf2
MB
236# All valid checks
237BEGIN {
9b494a7e
JJ
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
MB
242}
243
244# Debugging options
245my ($debug_op);
246
9b494a7e
JJ
247my %done_cv; # used to mark which subs have already been linted
248my @extra_packages; # Lint checks mainline code and all subs which are
249 # in main:: or in one of these packages.
a798dbf2
MB
250
251sub warning {
9b494a7e
JJ
252 my $format = ( @_ < 2 ) ? "%s" : shift @_;
253 warn sprintf( "$format at %s line %d\n", @_, $file, $line );
254 return undef;
a798dbf2
MB
255}
256
257# This gimme can't cope with context that's only determined
258# at runtime via dowantarray().
259sub gimme {
9b494a7e 260 my $op = shift @_;
a798dbf2 261 my $flags = $op->flags;
9b494a7e
JJ
262 if ( $flags & OPf_WANT ) {
263 return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
a798dbf2
MB
264 }
265 return undef;
266}
267
ca0b1549
JJ
268my @plugins;
269
9b494a7e
JJ
270sub 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
283sub 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
301for (
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 340sub B::OP::lint {
9b494a7e
JJ
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
JJ
349 return;
350}
fa75652c 351
a798dbf2 352sub B::COP::lint {
9b494a7e
JJ
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
MB
370}
371
372sub B::UNOP::lint {
9b494a7e
JJ
373 my ($op) = @_;
374
3f872cb9 375 my $opname = $op->name;
9b494a7e
JJ
376
377CONTEXT: {
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
JJ
410
411PRIVATE_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
MB
435}
436
437sub B::PMOP::lint {
9b494a7e
JJ
438 my ($op) = @_;
439
440IMPLICIT_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
JJ
450
451IMPLICIT_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
MB
466}
467
468sub B::LOOP::lint {
9b494a7e
JJ
469 my ($op) = @_;
470
471IMPLICIT_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
JJ
486
487 # Call all registered plugins
ca0b1549 488 my $m;
9b494a7e 489 $m = $_->can('match'), $op->$m( \%check ) for @plugins;
ca0b1549 490 return;
a798dbf2
MB
491}
492
9b494a7e
JJ
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 500sub B::SVOP::lint {
9b494a7e
JJ
501 my ($op) = @_;
502
503MAGIC_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
JJ
511
512BARE_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
540PRIVATE_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
JJ
563
564DOLLAR_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
JJ
580
581REGEXP_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
JJ
593
594UNDEFINED_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
JJ
616
617 # Call all registered plugins
ca0b1549 618 my $m;
9b494a7e 619 $m = $_->can('match'), $op->$m( \%check ) for @plugins;
ca0b1549 620 return;
a798dbf2
MB
621}
622
623sub B::GV::lintcv {
9b494a7e 624 my $gv = shift @_;
a798dbf2 625 my $cv = $gv->CV;
9b494a7e
JJ
626 return unless $cv->can('lintcv');
627 $cv->lintcv;
628 return;
629}
630
631sub B::CV::lintcv {
632
633 # Write to the *global* $
634 $curcv = shift @_;
635
a798dbf2 636 #warn sprintf("lintcv: %s::%s (done=%d)\n",
9b494a7e
JJ
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
JJ
642 walkoptree_slow( $root, "lint" ) if $$root;
643 return;
a798dbf2
MB
644}
645
646sub do_lint {
647 my %search_pack;
9b494a7e
JJ
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
MB
660 }
661
9b494a7e
JJ
662 walksymtable(
663 \%main::,
664 sub {
665 if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv }
666 },
667 sub {1}
668 );
669 return;
a798dbf2
MB
670}
671
672sub compile {
673 my @options = @_;
9b494a7e 674
a798dbf2 675 # Turn on default lint checks
9b494a7e
JJ
676 for my $opt (@default_checks) {
677 $check{$opt} = 1;
a798dbf2 678 }
9b494a7e
JJ
679
680OPTION:
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
JJ
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
JJ
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
JJ
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
JJ
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
MB
733 return \&do_lint;
734}
735
ca0b1549
JJ
736sub 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
JJ
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
JJ
749 $plugin_valid_check{$check} = $plugin;
750 }
fa75652c 751
ca0b1549 752 push @plugins, $plugin;
fa75652c 753
ca0b1549
JJ
754 return;
755}
756
a798dbf2 7571;