ext/B/B/Lint.pm

   1 package B::Lint;
   2
   3 our $VERSION = '1.02';
   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 B<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 will elicit a warning. Using an explicit B<scalar()> silences the
  40 warning. For example,
  41
  42     $foo = scalar(@bar);
  43
  44 =item B<implicit-read> and B<implicit-write>
  45
  46 These options produce a warning whenever an operation implicitly
  47 reads or (respectively) writes to one of Perl's special variables.
  48 For example, B<implicit-read> will warn about these:
  49
  50     /foo/;
  51
  52 and B<implicit-write> will warn about these:
  53
  54     s/foo/bar/;
  55
  56 Both B<implicit-read> and B<implicit-write> warn about this:
  57
  58     for (@a) { ... }
  59
  60 =item B<bare-subs>
  61
  62 This option warns whenever a bareword is implicitly quoted, but is also
  63 the name of a subroutine in the current package. Typical mistakes that it will
  64 trap are:
  65
  66         use constant foo => 'bar';
  67         @a = ( foo => 1 );
  68         $b{foo} = 2;
  69
  70 Neither of these will do what a naive user would expect.
  71
  72 =item B<dollar-underscore>
  73
  74 This option warns whenever $_ is used either explicitly anywhere or
  75 as the implicit argument of a B<print> statement.
  76
  77 =item B<private-names>
  78
  79 This option warns on each use of any variable, subroutine or
  80 method name that lives in a non-current package but begins with
  81 an underscore ("_"). Warnings aren't issued for the special case
  82 of the single character name "_" by itself (e.g. $_ and @_).
  83
  84 =item B<undefined-subs>
  85
  86 This option warns whenever an undefined subroutine is invoked.
  87 This option will only catch explicitly invoked subroutines such
  88 as C<foo()> and not indirect invocations such as C<&$subref()>
  89 or C<$obj-E<gt>meth()>. Note that some programs or modules delay
  90 definition of subs until runtime by means of the AUTOLOAD
  91 mechanism.
  92
  93 =item B<regexp-variables>
  94
  95 This option warns whenever one of the regexp variables $', $& or
  96 $' is used. Any occurrence of any of these variables in your
  97 program can slow your whole program down. See L<perlre> for
  98 details.
  99
 100 =item B<all>
 101
 102 Turn all warnings on.
 103
 104 =item B<none>
 105
 106 Turn all warnings off.
 107
 108 =back
 109
 110 =head1 NON LINT-CHECK OPTIONS
 111
 112 =over 8
 113
 114 =item B<-u Package>
 115
 116 Normally, Lint only checks the main code of the program together
 117 with all subs defined in package main. The B<-u> option lets you
 118 include other package names whose subs are then checked by Lint.
 119
 120 =back
 121
 122 =head1 BUGS
 123
 124 This is only a very preliminary version.
 125
 126 This module doesn't work correctly on thread-enabled perls.
 127
 128 =head1 AUTHOR
 129
 130 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 131
 132 =cut
 133
 134 use strict;
 135 use B qw(walkoptree_slow main_root walksymtable svref_2object parents
 136          OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
 137         );
 138
 139 my $file = "unknown";           # shadows current filename
 140 my $line = 0;                   # shadows current line number
 141 my $curstash = "main";          # shadows current stash
 142
 143 # Lint checks
 144 my %check;
 145 my %implies_ok_context;
 146 BEGIN {
 147     map($implies_ok_context{$_}++,
 148         qw(scalar av2arylen aelem aslice helem hslice
 149            keys values hslice defined undef delete));
 150 }
 151
 152 # Lint checks turned on by default
 153 my @default_checks = qw(context);
 154
 155 my %valid_check;
 156 # All valid checks
 157 BEGIN {
 158     map($valid_check{$_}++,
 159         qw(context implicit_read implicit_write dollar_underscore
 160            private_names bare_subs undefined_subs regexp_variables));
 161 }
 162
 163 # Debugging options
 164 my ($debug_op);
 165
 166 my %done_cv;            # used to mark which subs have already been linted
 167 my @extra_packages;     # Lint checks mainline code and all subs which are
 168                         # in main:: or in one of these packages.
 169
 170 sub warning {
 171     my $format = (@_ < 2) ? "%s" : shift;
 172     warn sprintf("$format at %s line %d\n", @_, $file, $line);
 173 }
 174
 175 # This gimme can't cope with context that's only determined
 176 # at runtime via dowantarray().
 177 sub gimme {
 178     my $op = shift;
 179     my $flags = $op->flags;
 180     if ($flags & OPf_WANT) {
 181         return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
 182     }
 183     return undef;
 184 }
 185
 186 sub B::OP::lint {}
 187
 188 sub B::COP::lint {
 189     my $op = shift;
 190     if ($op->name eq "nextstate") {
 191         $file = $op->file;
 192         $line = $op->line;
 193         $curstash = $op->stash->NAME;
 194     }
 195 }
 196
 197 sub B::UNOP::lint {
 198     my $op = shift;
 199     my $opname = $op->name;
 200     if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
 201         my $parent = parents->[0];
 202         my $pname = $parent->name;
 203         return if gimme($op) || $implies_ok_context{$pname};
 204         # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
 205         # null out the parent so we have to check for a parent of pp_null and
 206         # a grandparent of pp_enteriter or pp_delete
 207         if ($pname eq "null") {
 208             my $gpname = parents->[1]->name;
 209             return if $gpname eq "enteriter" || $gpname eq "delete";
 210         }
 211         warning("Implicit scalar context for %s in %s",
 212                 $opname eq "rv2av" ? "array" : "hash", $parent->desc);
 213     }
 214     if ($check{private_names} && $opname eq "method") {
 215         my $methop = $op->first;
 216         if ($methop->name eq "const") {
 217             my $method = $methop->sv->PV;
 218             if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
 219                 warning("Illegal reference to private method name $method");
 220             }
 221         }
 222     }
 223 }
 224
 225 sub B::PMOP::lint {
 226     my $op = shift;
 227     if ($check{implicit_read}) {
 228         if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
 229             warning('Implicit match on $_');
 230         }
 231     }
 232     if ($check{implicit_write}) {
 233         if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
 234             warning('Implicit substitution on $_');
 235         }
 236     }
 237 }
 238
 239 sub B::LOOP::lint {
 240     my $op = shift;
 241     if ($check{implicit_read} || $check{implicit_write}) {
 242         if ($op->name eq "enteriter") {
 243             my $last = $op->last;
 244             if ($last->name eq "gv" && $last->gv->NAME eq "_") {
 245                 warning('Implicit use of $_ in foreach');
 246             }
 247         }
 248     }
 249 }
 250
 251 sub B::SVOP::lint {
 252     my $op = shift;
 253     if ( $check{bare_subs} && $op->name eq 'const'
 254          && $op->private & 64 )         # OPpCONST_BARE = 64 in op.h
 255     {
 256         my $sv = $op->sv;
 257         if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) {
 258             warning "Bare sub name '" . $sv->PV . "' interpreted as string";
 259         }
 260     }
 261     if ($check{dollar_underscore} && $op->name eq "gvsv"
 262         && $op->gv->NAME eq "_")
 263     {
 264         warning('Use of $_');
 265     }
 266     if ($check{private_names}) {
 267         my $opname = $op->name;
 268         if ($opname eq "gv" || $opname eq "gvsv") {
 269             my $gv = $op->gv;
 270             if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
 271                 warning('Illegal reference to private name %s', $gv->NAME);
 272             }
 273         } elsif ($opname eq "method_named") {
 274             my $method = $op->gv->PV;
 275             if ($method =~ /^_./) {
 276                 warning("Illegal reference to private method name $method");
 277             }
 278         }
 279     }
 280     if ($check{undefined_subs}) {
 281         if ($op->name eq "gv"
 282             && $op->next->name eq "entersub")
 283         {
 284             my $gv = $op->gv;
 285             my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
 286             no strict 'refs';
 287             if (!defined(&$subname)) {
 288                 $subname =~ s/^main:://;
 289                 warning('Undefined subroutine %s called', $subname);
 290             }
 291         }
 292     }
 293     if ($check{regexp_variables} && $op->name eq "gvsv") {
 294         my $name = $op->gv->NAME;
 295         if ($name =~ /^[&'`]$/) {
 296             warning('Use of regexp variable $%s', $name);
 297         }
 298     }
 299 }
 300
 301 sub B::GV::lintcv {
 302     my $gv = shift;
 303     my $cv = $gv->CV;
 304     #warn sprintf("lintcv: %s::%s (done=%d)\n",
 305     #            $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
 306     return if !$$cv || $done_cv{$$cv}++;
 307     my $root = $cv->ROOT;
 308     #warn "    root = $root (0x$$root)\n";#debug
 309     walkoptree_slow($root, "lint") if $$root;
 310 }
 311
 312 sub do_lint {
 313     my %search_pack;
 314     walkoptree_slow(main_root, "lint") if ${main_root()};
 315
 316     # Now do subs in main
 317     no strict qw(vars refs);
 318     local(*glob);
 319     for my $sym (keys %main::) {
 320         next if $sym =~ /::$/;
 321         *glob = $main::{$sym};
 322         svref_2object(\*glob)->EGV->lintcv;
 323     }
 324
 325     # Now do subs in non-main packages given by -u options
 326     map { $search_pack{$_} = 1 } @extra_packages;
 327     walksymtable(\%{"main::"}, "lintcv", sub {
 328         my $package = shift;
 329         $package =~ s/::$//;
 330         #warn "Considering $package\n";#debug
 331         return exists $search_pack{$package};
 332     });
 333 }
 334
 335 sub compile {
 336     my @options = @_;
 337     my ($option, $opt, $arg);
 338     # Turn on default lint checks
 339     for $opt (@default_checks) {
 340         $check{$opt} = 1;
 341     }
 342   OPTION:
 343     while ($option = shift @options) {
 344         if ($option =~ /^-(.)(.*)/) {
 345             $opt = $1;
 346             $arg = $2;
 347         } else {
 348             unshift @options, $option;
 349             last OPTION;
 350         }
 351         if ($opt eq "-" && $arg eq "-") {
 352             shift @options;
 353             last OPTION;
 354         } elsif ($opt eq "D") {
 355             $arg ||= shift @options;
 356             foreach $arg (split(//, $arg)) {
 357                 if ($arg eq "o") {
 358                     B->debug(1);
 359                 } elsif ($arg eq "O") {
 360                     $debug_op = 1;
 361                 }
 362             }
 363         } elsif ($opt eq "u") {
 364             $arg ||= shift @options;
 365             push(@extra_packages, $arg);
 366         }
 367     }
 368     foreach $opt (@default_checks, @options) {
 369         $opt =~ tr/-/_/;
 370         if ($opt eq "all") {
 371             %check = %valid_check;
 372         }
 373         elsif ($opt eq "none") {
 374             %check = ();
 375         }
 376         else {
 377             if ($opt =~ s/^no_//) {
 378                 $check{$opt} = 0;
 379             }
 380             else {
 381                 $check{$opt} = 1;
 382             }
 383             warn "No such check: $opt\n" unless defined $valid_check{$opt};
 384         }
 385     }
 386     # Remaining arguments are things to check
 387
 388     return \&do_lint;
 389 }
 390
 391 1;