ext/B/B/Lint.pm

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