dist/B-Lint/lib/B/Lint.pm

   1 package B::Lint;
   2
   3 our $VERSION = '1.12';    ## no critic
   4
   5 =head1 NAME
   6
   7 B::Lint - Perl lint
   8
   9 =head1 SYNOPSIS
  10
  11 perl -MO=Lint[,OPTIONS] foo.pl
  12
  13 =head1 DESCRIPTION
  14
  15 The B::Lint module is equivalent to an extended version of the B<-w>
  16 option of B<perl>. It is named after the program F<lint> which carries
  17 out a similar process for C programs.
  18
  19 =head1 OPTIONS AND LINT CHECKS
  20
  21 Option words are separated by commas (not whitespace) and follow the
  22 usual conventions of compiler backend options. Following any options
  23 (indicated by a leading B<->) come lint check arguments. Each such
  24 argument (apart from the special B<all> and B<none> options) is a
  25 word representing one possible lint check (turning on that check) or
  26 is B<no-foo> (turning off that check). Before processing the check
  27 arguments, a standard list of checks is turned on. Later options
  28 override earlier ones. Available options are:
  29
  30 =over 8
  31
  32 =item B<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
  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;
  53
  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
  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
  81     use constant foo => 'bar';
  82     @a = ( foo => 1 );
  83     $b{foo} = 2;
  84
  85 Neither of these will do what a naive user would expect.
  86
  87 =item B<dollar-underscore>
  88
  89 This option warns whenever C<$_> is used either explicitly anywhere or
  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
  97 of the single character name "_" by itself (e.g. C<$_> and C<@_>).
  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
 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
 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
 137 =head1 EXTENDING LINT
 138
 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.
 142
 143 The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
 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.
 147
 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.
 151
 152 The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
 153 the current filename and line number.
 154
 155   package Sample;
 156   use B::Lint;
 157   B::Lint->register_plugin( Sample => [ 'good_taste' ] );
 158
 159   sub match {
 160       my ( $op, $checks_href ) = shift @_;
 161       if ( $checks_href->{good_taste} ) {
 162           ...
 163       }
 164   }
 165
 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
 178 =back
 179
 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 =head1 ACKNOWLEDGEMENTS
 189
 190 Sebastien Aperghis-Tramoni - bug fixes
 191
 192 =cut
 193
 194 use strict;
 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 );
 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 }
 207
 208 BEGIN {
 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.
 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
 219         if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) {
 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
 233
 234 sub file     {$file}
 235 sub line     {$line}
 236 sub curstash {$curstash}
 237 sub curcv    {$curcv}
 238
 239 # Lint checks
 240 my %check;
 241 my %implies_ok_context;
 242
 243 map( $implies_ok_context{$_}++,
 244     qw(scalar av2arylen aelem aslice helem hslice
 245         keys values hslice defined undef delete) );
 246
 247 # Lint checks turned on by default
 248 my @default_checks
 249     = qw(context magic_diamond undefined_subs regexp_variables);
 250
 251 my %valid_check;
 252
 253 # All valid checks
 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__;
 261 }
 262
 263 # Debugging options
 264 my ($debug_op);
 265
 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.
 269
 270 sub warning {
 271     my $format = ( @_ < 2 ) ? "%s" : shift @_;
 272     warn sprintf( "$format at %s line %d\n", @_, $file, $line );
 273     return undef;      ## no critic undef
 274 }
 275
 276 # This gimme can't cope with context that's only determined
 277 # at runtime via dowantarray().
 278 sub gimme {
 279     my $op    = shift @_;
 280     my $flags = $op->flags;
 281     if ( $flags & OPf_WANT ) {
 282         return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
 283     }
 284     return undef;      ## no critic undef
 285 }
 286
 287 my @plugins = __PACKAGE__->plugins;
 288
 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.
 294     return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() };
 295 }
 296
 297 sub inside_foreach_modifier {
 298
 299     # TODO: use any()
 300
 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 ) = @$_;
 336     my $target = do {    ## no critic strict
 337         no strict 'refs';
 338         \*$subname;
 339     };
 340     *$target = sub {
 341         my ($op) = @_;
 342
 343         my $elt;
 344         if ( not $op->isa('B::PADOP') ) {
 345             $elt = $op->$attr;
 346         }
 347         return $elt if eval { $elt->isa('B::SV') };
 348
 349         my $ix         = $op->$pad_attr;
 350         my @entire_pad = $curcv->PADLIST->ARRAY;
 351         my @elts       = map +( $_->ARRAY )[$ix], @entire_pad;
 352         ($elt) = first {
 353             eval { $_->isa('B::SV') } ? $_ : ();
 354         }
 355         @elts[ 0, reverse 1 .. $#elts ];
 356         return $elt;
 357     };
 358 }
 359
 360 sub B::OP::lint {
 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
 367     my $m;
 368     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 369     return;
 370 }
 371
 372 sub B::COP::lint {
 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;
 384     }
 385
 386     # Call all registered plugins
 387     my $m;
 388     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 389     return;
 390 }
 391
 392 sub B::UNOP::lint {
 393     my ($op) = @_;
 394
 395     my $opname = $op->name;
 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;
 429     }
 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;
 449     }
 450
 451     # Call all registered plugins
 452     my $m;
 453     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 454     return;
 455 }
 456
 457 sub B::PMOP::lint {
 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 $_';
 469     }
 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 $_';
 480     }
 481
 482     # Call all registered plugins
 483     my $m;
 484     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 485     return;
 486 }
 487
 488 sub B::LOOP::lint {
 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';
 505     }
 506
 507     # Call all registered plugins
 508     my $m;
 509     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 510     return;
 511 }
 512
 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.
 518 *B::PADOP::lint = *B::PADOP::lint = \&B::SVOP::lint;
 519
 520 sub B::SVOP::lint {
 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 <>';
 530     }
 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         }
 582     }
 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 $_';
 599     }
 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;
 612     }
 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
 626         no strict 'refs';    ## no critic strict
 627         if ( not exists &$subname ) {
 628             $subname =~ s/\Amain:://;
 629             warning q[Nonexistent subroutine '%s' called], $subname;
 630         }
 631         elsif ( not defined &$subname ) {
 632             $subname =~ s/\A\&?main:://;
 633             warning q[Undefined subroutine '%s' called], $subname;
 634         }
 635     }
 636
 637     # Call all registered plugins
 638     my $m;
 639     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 640     return;
 641 }
 642
 643 sub B::GV::lintcv {
 644
 645     # Example: B::svref_2object( \ *A::Glob )->lintcv
 646
 647     my $gv = shift @_;
 648     my $cv = $gv->CV;
 649     return unless $cv->can('lintcv');
 650     $cv->lintcv;
 651     return;
 652 }
 653
 654 sub B::CV::lintcv {
 655
 656     # Example: B::svref_2object( \ &foo )->lintcv
 657
 658     # Write to the *global* $
 659     $curcv = shift @_;
 660
 661     #warn sprintf("lintcv: %s::%s (done=%d)\n",
 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
 666     #warn "    root = $root (0x$$root)\n";#debug
 667     walkoptree_slow( $root, "lint" ) if $$root;
 668     return;
 669 }
 670
 671 sub do_lint {
 672     my %search_pack;
 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 ) {
 680         next unless eval { $av->isa('B::AV') };
 681         for my $cv ( $av->ARRAY ) {
 682             next unless ref($cv) and $cv->FILE eq $0;
 683             $cv->lintcv;
 684         }
 685     }
 686
 687     walksymtable(
 688         \%main::,
 689         sub {
 690             if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv }
 691         },
 692         sub {1}
 693     );
 694     return;
 695 }
 696
 697 sub compile {
 698     my @options = @_;
 699
 700     # Turn on default lint checks
 701     for my $opt (@default_checks) {
 702         $check{$opt} = 1;
 703     }
 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" ) {
 718             $arg ||= shift @options;
 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         }
 732     }
 733
 734     foreach my $opt ( @default_checks, @options ) {
 735         $opt =~ tr/-/_/;
 736         if ( $opt eq "all" ) {
 737             %check = %valid_check;
 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             }
 749             carp "No such check: $opt"
 750                 unless defined $valid_check{$opt};
 751         }
 752     }
 753
 754     # Remaining arguments are things to check. So why aren't I
 755     # capturing them or something? I don't know.
 756
 757     return \&do_lint;
 758 }
 759
 760 sub register_plugin {
 761     my ( undef, $plugin, $new_checks ) = @_;
 762
 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;
 779     }
 780
 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     }
 788
 789     return;
 790 }
 791
 792 1;