ext/B/B/Lint.pm

   1 package B::Lint;
   2
   3 our $VERSION = '1.08';
   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 registering plugins.
 140
 141 The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
 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
 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.
 148
 149 You may not alter the %checks hash reference.
 150
 151 The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
 152 the current filename and line number.
 153
 154   package Sample;
 155   use B::Lint;
 156   B::Lint->register_plugin( Sample => [ 'good_taste' ] );
 157
 158   sub match {
 159       my ( $op, $checks_href ) = shift @_;
 160       if ( $checks_href->{good_taste} ) {
 161           ...
 162       }
 163   }
 164
 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
 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;
 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 );
 192
 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
 214
 215 sub file     {$file}
 216 sub line     {$line}
 217 sub curstash {$curstash}
 218 sub curcv    {$curcv}
 219
 220 # Lint checks
 221 my %check;
 222 my %implies_ok_context;
 223
 224 BEGIN {
 225     map( $implies_ok_context{$_}++,
 226         qw(scalar av2arylen aelem aslice helem hslice
 227             keys values hslice defined undef delete) );
 228 }
 229
 230 # Lint checks turned on by default
 231 my @default_checks = qw(context);
 232
 233 my %valid_check;
 234 my %plugin_valid_check;
 235
 236 # All valid checks
 237 BEGIN {
 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 ) );
 242 }
 243
 244 # Debugging options
 245 my ($debug_op);
 246
 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.
 250
 251 sub warning {
 252     my $format = ( @_ < 2 ) ? "%s" : shift @_;
 253     warn sprintf( "$format at %s line %d\n", @_, $file, $line );
 254     return undef;
 255 }
 256
 257 # This gimme can't cope with context that's only determined
 258 # at runtime via dowantarray().
 259 sub gimme {
 260     my $op    = shift @_;
 261     my $flags = $op->flags;
 262     if ( $flags & OPf_WANT ) {
 263         return ( ( $flags & OPf_WANT ) == OPf_WANT_LIST ? 1 : 0 );
 264     }
 265     return undef;
 266 }
 267
 268 my @plugins;
 269
 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
 340 sub B::OP::lint {
 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
 347     my $m;
 348     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 349     return;
 350 }
 351
 352 sub B::COP::lint {
 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;
 364     }
 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::UNOP::lint {
 373     my ($op) = @_;
 374
 375     my $opname = $op->name;
 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;
 409     }
 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;
 429     }
 430
 431     # Call all registered plugins
 432     my $m;
 433     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 434     return;
 435 }
 436
 437 sub B::PMOP::lint {
 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 $_';
 449     }
 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 $_';
 460     }
 461
 462     # Call all registered plugins
 463     my $m;
 464     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 465     return;
 466 }
 467
 468 sub B::LOOP::lint {
 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';
 485     }
 486
 487     # Call all registered plugins
 488     my $m;
 489     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 490     return;
 491 }
 492
 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;
 499
 500 sub B::SVOP::lint {
 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 <>';
 510     }
 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         }
 562     }
 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 $_';
 579     }
 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;
 592     }
 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         }
 615     }
 616
 617     # Call all registered plugins
 618     my $m;
 619     $m = $_->can('match'), $op->$m( \%check ) for @plugins;
 620     return;
 621 }
 622
 623 sub B::GV::lintcv {
 624     my $gv = shift @_;
 625     my $cv = $gv->CV;
 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
 636     #warn sprintf("lintcv: %s::%s (done=%d)\n",
 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
 641     #warn "    root = $root (0x$$root)\n";#debug
 642     walkoptree_slow( $root, "lint" ) if $$root;
 643     return;
 644 }
 645
 646 sub do_lint {
 647     my %search_pack;
 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         }
 660     }
 661
 662     walksymtable(
 663         \%main::,
 664         sub {
 665             if ( $_[0]->FILE eq $0 ) { $_[0]->lintcv }
 666         },
 667         sub {1}
 668     );
 669     return;
 670 }
 671
 672 sub compile {
 673     my @options = @_;
 674
 675     # Turn on default lint checks
 676     for my $opt (@default_checks) {
 677         $check{$opt} = 1;
 678     }
 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" ) {
 693             $arg ||= shift @options;
 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         }
 707     }
 708
 709     foreach my $opt ( @default_checks, @options ) {
 710         $opt =~ tr/-/_/;
 711         if ( $opt eq "all" ) {
 712             %check = ( %valid_check, %plugin_valid_check );
 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         }
 728     }
 729
 730     # Remaining arguments are things to check. So why aren't I
 731     # capturing them or something? I don't know.
 732
 733     return \&do_lint;
 734 }
 735
 736 sub register_plugin {
 737     my ( undef, $plugin, $new_checks ) = @_;
 738
 739     # Register the plugin
 740     for my $check (@$new_checks) {
 741         defined $check
 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.";
 748
 749         $plugin_valid_check{$check} = $plugin;
 750     }
 751
 752     push @plugins, $plugin;
 753
 754     return;
 755 }
 756
 757 1;