ext/B/B/Lint.pm

   1 package B::Lint;
   2
   3 our $VERSION = '1.06';
   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<context>
  33
  34 Produces a warning whenever an array is used in an implicit scalar
  35 context. For example, both of the lines
  36
  37     $foo = length(@bar);
  38     $foo = @bar;
  39
  40 will elicit a warning. Using an explicit B<scalar()> silences the
  41 warning. For example,
  42
  43     $foo = scalar(@bar);
  44
  45 =item B<implicit-read> and B<implicit-write>
  46
  47 These options produce a warning whenever an operation implicitly
  48 reads or (respectively) writes to one of Perl's special variables.
  49 For example, B<implicit-read> will warn about these:
  50
  51     /foo/;
  52
  53 and B<implicit-write> will warn about these:
  54
  55     s/foo/bar/;
  56
  57 Both B<implicit-read> and B<implicit-write> warn about this:
  58
  59     for (@a) { ... }
  60
  61 =item B<bare-subs>
  62
  63 This option warns whenever a bareword is implicitly quoted, but is also
  64 the name of a subroutine in the current package. Typical mistakes that it will
  65 trap are:
  66
  67     use constant foo => 'bar';
  68     @a = ( foo => 1 );
  69     $b{foo} = 2;
  70
  71 Neither of these will do what a naive user would expect.
  72
  73 =item B<dollar-underscore>
  74
  75 This option warns whenever C<$_> is used either explicitly anywhere or
  76 as the implicit argument of a B<print> statement.
  77
  78 =item B<private-names>
  79
  80 This option warns on each use of any variable, subroutine or
  81 method name that lives in a non-current package but begins with
  82 an underscore ("_"). Warnings aren't issued for the special case
  83 of the single character name "_" by itself (e.g. C<$_> and C<@_>).
  84
  85 =item B<undefined-subs>
  86
  87 This option warns whenever an undefined subroutine is invoked.
  88 This option will only catch explicitly invoked subroutines such
  89 as C<foo()> and not indirect invocations such as C<&$subref()>
  90 or C<$obj-E<gt>meth()>. Note that some programs or modules delay
  91 definition of subs until runtime by means of the AUTOLOAD
  92 mechanism.
  93
  94 =item B<regexp-variables>
  95
  96 This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
  97 is used. Any occurrence of any of these variables in your
  98 program can slow your whole program down. See L<perlre> for
  99 details.
 100
 101 =item B<all>
 102
 103 Turn all warnings on.
 104
 105 =item B<none>
 106
 107 Turn all warnings off.
 108
 109 =back
 110
 111 =head1 NON LINT-CHECK OPTIONS
 112
 113 =over 8
 114
 115 =item B<-u Package>
 116
 117 Normally, Lint only checks the main code of the program together
 118 with all subs defined in package main. The B<-u> option lets you
 119 include other package names whose subs are then checked by Lint.
 120
 121 =back
 122
 123 =head1 EXTENDING LINT
 124
 125 Lint can be extended by registering plugins.
 126
 127 The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
 128 adds the class C<MyPlugin> to the list of plugins. It also adds the
 129 list of C<@new_checks> to the list of valid checks.
 130
 131 You must create a C<match( \%checks )> method in your plugin class or one
 132 of its parents. It will be called on every op as a regular method call
 133 with a hash ref of checks as its parameter.
 134
 135 You may not alter the %checks hash reference.
 136
 137 The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
 138 the current filename and line number.
 139
 140   package Sample;
 141   use B::Lint;
 142   B::Lint->register_plugin( Sample => [ 'good_taste' ] );
 143
 144   sub match {
 145       my ( $op, $checks_href ) = shift;
 146       if ( $checks_href->{good_taste} ) {
 147           ...
 148       }
 149   }
 150
 151 =head1 BUGS
 152
 153 This is only a very preliminary version.
 154
 155 This module doesn't work correctly on thread-enabled perls.
 156
 157 =head1 AUTHOR
 158
 159 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 160
 161 =cut
 162
 163 use strict;
 164 use B qw(walkoptree_slow main_root walksymtable svref_2object parents
 165          class
 166          OPpOUR_INTRO
 167          OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
 168         );
 169
 170 my $file = "unknown";           # shadows current filename
 171 my $line = 0;                   # shadows current line number
 172 my $curstash = "main";          # shadows current stash
 173
 174 sub file { $file }
 175 sub line { $line }
 176
 177 # Lint checks
 178 my %check;
 179 my %implies_ok_context;
 180 BEGIN {
 181     map($implies_ok_context{$_}++,
 182         qw(scalar av2arylen aelem aslice helem hslice
 183            keys values hslice defined undef delete));
 184 }
 185
 186 # Lint checks turned on by default
 187 my @default_checks = qw(context);
 188
 189 my %valid_check;
 190 my %plugin_valid_check;
 191 # All valid checks
 192 BEGIN {
 193     map($valid_check{$_}++,
 194         qw(context implicit_read implicit_write dollar_underscore
 195            private_names bare_subs undefined_subs regexp_variables));
 196 }
 197
 198 # Debugging options
 199 my ($debug_op);
 200
 201 my %done_cv;            # used to mark which subs have already been linted
 202 my @extra_packages;     # Lint checks mainline code and all subs which are
 203                         # in main:: or in one of these packages.
 204
 205 sub warning {
 206     my $format = (@_ < 2) ? "%s" : shift;
 207     warn sprintf("$format at %s line %d\n", @_, $file, $line);
 208 }
 209
 210 # This gimme can't cope with context that's only determined
 211 # at runtime via dowantarray().
 212 sub gimme {
 213     my $op = shift;
 214     my $flags = $op->flags;
 215     if ($flags & OPf_WANT) {
 216         return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
 217     }
 218     return undef;
 219 }
 220
 221 my @plugins;
 222
 223 sub B::OP::lint {
 224     my $op = shift;
 225     my $m;
 226     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
 227     return;
 228 }
 229
 230 *$_ = *B::OP::lint
 231   for \ ( *B::PADOP::lint,
 232           *B::LOGOP::lint,
 233           *B::BINOP::lint,
 234           *B::LISTOP::lint );
 235
 236 sub B::COP::lint {
 237     my $op = shift;
 238     if ($op->name eq "nextstate") {
 239         $file = $op->file;
 240         $line = $op->line;
 241         $curstash = $op->stash->NAME;
 242     }
 243
 244     my $m;
 245     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
 246     return;
 247 }
 248
 249 sub B::UNOP::lint {
 250     my $op = shift;
 251     my $opname = $op->name;
 252     if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
 253         my $parent = parents->[0];
 254         my $pname = $parent->name;
 255         return if gimme($op) || $implies_ok_context{$pname};
 256         # Three special cases to deal with: "foreach (@foo)", "delete $a{$b}", and "exists $a{$b}"
 257         # null out the parent so we have to check for a parent of pp_null and
 258         # a grandparent of pp_enteriter, pp_delete, pp_exists
 259         if ($pname eq "null") {
 260             my $gpname = parents->[1]->name;
 261             return if $gpname eq "enteriter"
 262                    or $gpname eq "delete"
 263                    or $gpname eq "exists";
 264         }
 265
 266         # our( @bar );
 267         return if $op->private & OPpOUR_INTRO
 268                   and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID;
 269
 270         warning("Implicit scalar context for %s in %s",
 271                 $opname eq "rv2av" ? "array" : "hash", $parent->desc);
 272     }
 273     if ($check{private_names} && $opname eq "method") {
 274         my $methop = $op->first;
 275         if ($methop->name eq "const") {
 276             my $method = $methop->sv->PV;
 277             if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
 278                 warning("Illegal reference to private method name $method");
 279             }
 280         }
 281     }
 282
 283     my $m;
 284     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
 285     return;
 286 }
 287
 288 sub B::PMOP::lint {
 289     my $op = shift;
 290     if ($check{implicit_read}) {
 291         if ($op->name eq "match"
 292                 and not ( $op->flags & OPf_STACKED
 293                     or join( " ",
 294                         map $_->name,
 295                         @{B::parents()} )
 296                 =~ /^(?:leave )?(?:null )*grep/ ) ) {
 297             warning('Implicit match on $_');
 298         }
 299     }
 300     if ($check{implicit_write}) {
 301         if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
 302             warning('Implicit substitution on $_');
 303         }
 304     }
 305
 306     my $m;
 307     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
 308     return;
 309 }
 310
 311 sub B::LOOP::lint {
 312     my $op = shift;
 313     if ($check{implicit_read} || $check{implicit_write}) {
 314         if ($op->name eq "enteriter") {
 315             my $last = $op->last;
 316             my $body = $op->redoop;
 317             if ( $last->name eq "gv"
 318                  and $last->gv->NAME eq "_"
 319                  and $body->name =~ /\A(?:next|db|set)state\z/ ) {
 320                 warning('Implicit use of $_ in foreach');
 321             }
 322         }
 323     }
 324
 325     my $m;
 326     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
 327     return;
 328 }
 329
 330 sub _inside_foreach_statement {
 331     for my $op ( @{ parents() || [] } ) {
 332         $op->name eq 'leaveloop' or next;
 333         my $first = $op->first;
 334         $first->name eq 'enteriter' or next;
 335         $first->redoop->name !~ /\A(?:next|db|set)state\z/ or next;
 336         return 1;
 337     }
 338     return 0;
 339 }
 340
 341 sub B::SVOP::lint {
 342     my $op = shift;
 343     if ( $check{bare_subs} && $op->name eq 'const'
 344          && $op->private & 64 )         # OPpCONST_BARE = 64 in op.h
 345     {
 346         my $sv = $op->sv;
 347         if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) {
 348             warning "Bare sub name '" . $sv->PV . "' interpreted as string";
 349         }
 350     }
 351     if ($check{dollar_underscore}
 352         and $op->name eq "gvsv"
 353         and $op->gv->NAME eq "_"
 354         and not ( _inside_foreach_statement()
 355                   or do { my $ctx = join( ' ',
 356                                           map $_->name,
 357                                           @{ parents() || [] } );
 358                           $ctx =~ /(grep|map)start \1while/ } ) )
 359     {
 360         warning('Use of $_');
 361     }
 362     if ($check{private_names}) {
 363         my $opname = $op->name;
 364         if ($opname eq "gv" || $opname eq "gvsv") {
 365             my $gv = $op->gv;
 366             if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
 367                 warning('Illegal reference to private name %s', $gv->NAME);
 368             }
 369         } elsif ($opname eq "method_named") {
 370             my $method = $op->gv->PV;
 371             if ($method =~ /^_./) {
 372                 warning("Illegal reference to private method name $method");
 373             }
 374         }
 375     }
 376     if ($check{undefined_subs}) {
 377         if ($op->name eq "gv"
 378             && $op->next->name eq "entersub")
 379         {
 380             my $gv = $op->gv;
 381             my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
 382             no strict 'refs';
 383             if (!defined(&$subname)) {
 384                 $subname =~ s/^main:://;
 385                 warning('Undefined subroutine %s called', $subname);
 386             }
 387         }
 388     }
 389     if ($check{regexp_variables} && $op->name eq "gvsv") {
 390         my $name = $op->gv->NAME;
 391         if ($name =~ /^[&'`]$/) {
 392             warning('Use of regexp variable $%s', $name);
 393         }
 394     }
 395
 396     my $m;
 397     $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
 398     return;
 399 }
 400
 401 sub B::GV::lintcv {
 402     my $gv = shift;
 403     my $cv = $gv->CV;
 404     #warn sprintf("lintcv: %s::%s (done=%d)\n",
 405     #            $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
 406     return if !$$cv || $done_cv{$$cv}++;
 407     my $root = $cv->ROOT;
 408     #warn "    root = $root (0x$$root)\n";#debug
 409     walkoptree_slow($root, "lint") if $$root;
 410 }
 411
 412 sub do_lint {
 413     my %search_pack;
 414     walkoptree_slow(main_root, "lint") if ${main_root()};
 415
 416     # Now do subs in main
 417     no strict qw(vars refs);
 418     local(*glob);
 419     for my $sym (keys %main::) {
 420         next if $sym =~ /::$/;
 421         *glob = $main::{$sym};
 422
 423         # When is EGV a special value?
 424         my $gv = svref_2object(\*glob)->EGV;
 425         next if class( $gv ) eq 'SPECIAL';
 426         $gv->lintcv;
 427     }
 428
 429     # Now do subs in non-main packages given by -u options
 430     map { $search_pack{$_} = 1 } @extra_packages;
 431     walksymtable(\%{"main::"}, "lintcv", sub {
 432         my $package = shift;
 433         $package =~ s/::$//;
 434         #warn "Considering $package\n";#debug
 435         return exists $search_pack{$package};
 436     });
 437 }
 438
 439 sub compile {
 440     my @options = @_;
 441     my ($option, $opt, $arg);
 442     # Turn on default lint checks
 443     for $opt (@default_checks) {
 444         $check{$opt} = 1;
 445     }
 446   OPTION:
 447     while ($option = shift @options) {
 448         if ($option =~ /^-(.)(.*)/) {
 449             $opt = $1;
 450             $arg = $2;
 451         } else {
 452             unshift @options, $option;
 453             last OPTION;
 454         }
 455         if ($opt eq "-" && $arg eq "-") {
 456             shift @options;
 457             last OPTION;
 458         } elsif ($opt eq "D") {
 459             $arg ||= shift @options;
 460             foreach $arg (split(//, $arg)) {
 461                 if ($arg eq "o") {
 462                     B->debug(1);
 463                 } elsif ($arg eq "O") {
 464                     $debug_op = 1;
 465                 }
 466             }
 467         } elsif ($opt eq "u") {
 468             $arg ||= shift @options;
 469             push(@extra_packages, $arg);
 470         }
 471     }
 472     foreach $opt (@default_checks, @options) {
 473         $opt =~ tr/-/_/;
 474         if ($opt eq "all") {
 475             %check = ( %valid_check, %plugin_valid_check );
 476         }
 477         elsif ($opt eq "none") {
 478             %check = ();
 479         }
 480         else {
 481             if ($opt =~ s/^no_//) {
 482                 $check{$opt} = 0;
 483             }
 484             else {
 485                 $check{$opt} = 1;
 486             }
 487             warn "No such check: $opt\n" unless defined $valid_check{$opt}
 488                                              or defined $plugin_valid_check{$opt};
 489         }
 490     }
 491     # Remaining arguments are things to check
 492
 493     return \&do_lint;
 494 }
 495
 496 sub register_plugin {
 497     my ( undef, $plugin, $new_checks ) = @_;
 498
 499     # Register the plugin
 500     for my $check ( @$new_checks ) {
 501         defined $check
 502           or warn "Undefined value in checks.";
 503         not $valid_check{ $check }
 504           or warn "$check is already registered as a B::Lint feature.";
 505         not $plugin_valid_check{ $check }
 506           or warn "$check is already registered as a $plugin_valid_check{$check} feature.";
 507
 508         $plugin_valid_check{$check} = $plugin;
 509     }
 510
 511     push @plugins, $plugin;
 512
 513     return;
 514 }
 515
 516 1;