ext/B/B/Lint.pm

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