[Summary view] [Print] [Text view]

   1  package B::Lint;
   2  
   3  our $VERSION = '1.09';    ## 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  =cut
 189  
 190  use strict;
 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 );
 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 }
 203  
 204  BEGIN {
 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.
 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  
 215          if ( any { $sym eq $_ } @B::EXPORT_OK, @B::EXPORT ) {
 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
 229  
 230  sub file     {$file}
 231  sub line     {$line}
 232  sub curstash {$curstash}
 233  sub curcv    {$curcv}
 234  
 235  # Lint checks
 236  my %check;
 237  my %implies_ok_context;
 238  
 239  map( $implies_ok_context{$_}++,
 240      qw(scalar av2arylen aelem aslice helem hslice
 241          keys values hslice defined undef delete) );
 242  
 243  # Lint checks turned on by default
 244  my @default_checks
 245      = qw(context magic_diamond undefined_subs regexp_variables);
 246  
 247  my %valid_check;
 248  
 249  # All valid checks
 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__;
 257  }
 258  
 259  # Debugging options
 260  my ($debug_op);
 261  
 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.
 265  
 266  sub warning {
 267      my $format = ( @_ < 2 ) ? "%s" : shift @_;
 268      warn sprintf( "$format at %s line %d\n", @_, $file, $line );
 269      return undef;      ## no critic undef
 270  }
 271  
 272  # This gimme can't cope with context that's only determined
 273  # at runtime via dowantarray().
 274  sub gimme {
 275      my $op    = shift @_;
 276      my $flags = $op->flags;
 277      if ( $flags & OPf_WANT ) {
 278          return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
 279      }
 280      return undef;      ## no critic undef
 281  }
 282  
 283  my @plugins = __PACKAGE__->plugins;
 284  
 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.
 290      return any { $_->name =~ m/\A(?:grep|map)/xms } @{ parents() };
 291  }
 292  
 293  sub inside_foreach_modifier {
 294  
 295      # TODO: use any()
 296  
 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 ) = @$_;
 332      my $target = do {    ## no critic strict
 333          no strict 'refs';
 334          \*$subname;
 335      };
 336      *$target = sub {
 337          my ($op) = @_;
 338  
 339          my $elt;
 340          if ( not $op->isa('B::PADOP') ) {
 341              $elt = $op->$attr;
 342          }
 343          return $elt if eval { $elt->isa('B::SV') };
 344  
 345          my $ix         = $op->$pad_attr;
 346          my @entire_pad = $curcv->PADLIST->ARRAY;
 347          my @elts       = map +( $_->ARRAY )[$ix], @entire_pad;
 348          ($elt) = first {
 349              eval { $_->isa('B::SV') } ? $_ : ();
 350              }
 351              @elts[ 0, reverse 1 .. $#elts ];
 352          return $elt;
 353      };
 354  }
 355  
 356  sub B::OP::lint {
 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
 363      my $m;
 364      $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 365      return;
 366  }
 367  
 368  sub B::COP::lint {
 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;
 380      }
 381  
 382      # Call all registered plugins
 383      my $m;
 384      $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 385      return;
 386  }
 387  
 388  sub B::UNOP::lint {
 389      my ($op) = @_;
 390  
 391      my $opname = $op->name;
 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;
 425      }
 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;
 445      }
 446  
 447      # Call all registered plugins
 448      my $m;
 449      $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 450      return;
 451  }
 452  
 453  sub B::PMOP::lint {
 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 $_';
 465      }
 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 $_';
 476      }
 477  
 478      # Call all registered plugins
 479      my $m;
 480      $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 481      return;
 482  }
 483  
 484  sub B::LOOP::lint {
 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';
 501      }
 502  
 503      # Call all registered plugins
 504      my $m;
 505      $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 506      return;
 507  }
 508  
 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;
 515  
 516  sub B::SVOP::lint {
 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 <>';
 526      }
 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          }
 578      }
 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 $_';
 595      }
 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;
 608      }
 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  
 622          no strict 'refs';    ## no critic strict
 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          }
 631      }
 632  
 633      # Call all registered plugins
 634      my $m;
 635      $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 636      return;
 637  }
 638  
 639  sub B::GV::lintcv {
 640  
 641      # Example: B::svref_2object( \ *A::Glob )->lintcv
 642  
 643      my $gv = shift @_;
 644      my $cv = $gv->CV;
 645      return unless $cv->can('lintcv');
 646      $cv->lintcv;
 647      return;
 648  }
 649  
 650  sub B::CV::lintcv {
 651  
 652      # Example: B::svref_2object( \ &foo )->lintcv
 653  
 654      # Write to the *global* $
 655      $curcv = shift @_;
 656  
 657      #warn sprintf("lintcv: %s::%s (done=%d)\n",
 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  
 662      #warn "    root = $root (0x$$root)\n";#debug
 663      walkoptree_slow( $root, "lint" ) if $$root;
 664      return;
 665  }
 666  
 667  sub do_lint {
 668      my %search_pack;
 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 ) {
 676          next unless eval { $av->isa('B::AV') };
 677          for my $cv ( $av->ARRAY ) {
 678              next unless ref($cv) and $cv->FILE eq $0;
 679              $cv->lintcv;
 680          }
 681      }
 682  
 683      walksymtable(
 684          \%main::,
 685          sub {
 686              if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv }
 687          },
 688          sub {1}
 689      );
 690      return;
 691  }
 692  
 693  sub compile {
 694      my @options = @_;
 695  
 696      # Turn on default lint checks
 697      for my $opt (@default_checks) {
 698          $check{$opt} = 1;
 699      }
 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" ) {
 714              $arg ||= shift @options;
 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          }
 728      }
 729  
 730      foreach my $opt ( @default_checks, @options ) {
 731          $opt =~ tr/-/_/;
 732          if ( $opt eq "all" ) {
 733              %check = %valid_check;
 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              }
 745              carp "No such check: $opt"
 746                  unless defined $valid_check{$opt};
 747          }
 748      }
 749  
 750      # Remaining arguments are things to check. So why aren't I
 751      # capturing them or something? I don't know.
 752  
 753      return \&do_lint;
 754  }
 755  
 756  sub register_plugin {
 757      my ( undef, $plugin, $new_checks ) = @_;
 758  
 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;
 775      }
 776  
 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      }
 784  
 785      return;
 786  }
 787  
 788  1;