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(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice
 133            pp_keys pp_values pp_hslice pp_defined pp_undef pp_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->ppaddr eq "pp_nextstate") {
 175         $file = $op->filegv->SV->PV;
 176         $line = $op->line;
 177         $curstash = $op->stash->NAME;
 178     }
 179 }
 180
 181 sub B::UNOP::lint {
 182     my $op = shift;
 183     my $ppaddr = $op->ppaddr;
 184     if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) {
 185         my $parent = parents->[0];
 186         my $pname = $parent->ppaddr;
 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 "pp_null") {
 192             my $gpname = parents->[1]->ppaddr;
 193             return if $gpname eq "pp_enteriter" || $gpname eq "pp_delete";
 194         }
 195         warning("Implicit scalar context for %s in %s",
 196                 $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc);
 197     }
 198     if ($check{private_names} && $ppaddr eq "pp_method") {
 199         my $methop = $op->first;
 200         if ($methop->ppaddr eq "pp_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         my $ppaddr = $op->ppaddr;
 213         if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) {
 214             warning('Implicit match on $_');
 215         }
 216     }
 217     if ($check{implicit_write}) {
 218         my $ppaddr = $op->ppaddr;
 219         if ($ppaddr eq "pp_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         my $ppaddr = $op->ppaddr;
 229         if ($ppaddr eq "pp_enteriter") {
 230             my $last = $op->last;
 231             if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") {
 232                 warning('Implicit use of $_ in foreach');
 233             }
 234         }
 235     }
 236 }
 237
 238 sub B::GVOP::lint {
 239     my $op = shift;
 240     if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv"
 241         && $op->gv->NAME eq "_")
 242     {
 243         warning('Use of $_');
 244     }
 245     if ($check{private_names}) {
 246         my $ppaddr = $op->ppaddr;
 247         my $gv = $op->gv;
 248         if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv")
 249             && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash)
 250         {
 251             warning('Illegal reference to private name %s', $gv->NAME);
 252         }
 253     }
 254     if ($check{undefined_subs}) {
 255         if ($op->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") {
 256             my $gv = $op->gv;
 257             my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
 258             no strict 'refs';
 259             if (!defined(&$subname)) {
 260                 $subname =~ s/^main:://;
 261                 warning('Undefined subroutine %s called', $subname);
 262             }
 263         }
 264     }
 265     if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") {
 266         my $name = $op->gv->NAME;
 267         if ($name =~ /^[&'`]$/) {
 268             warning('Use of regexp variable $%s', $name);
 269         }
 270     }
 271 }
 272
 273 sub B::GV::lintcv {
 274     my $gv = shift;
 275     my $cv = $gv->CV;
 276     #warn sprintf("lintcv: %s::%s (done=%d)\n",
 277     #            $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
 278     return if !$$cv || $done_cv{$$cv}++;
 279     my $root = $cv->ROOT;
 280     #warn "    root = $root (0x$$root)\n";#debug
 281     walkoptree_slow($root, "lint") if $$root;
 282 }
 283
 284 sub do_lint {
 285     my %search_pack;
 286     walkoptree_slow(main_root, "lint") if ${main_root()};
 287
 288     # Now do subs in main
 289     no strict qw(vars refs);
 290     my $sym;
 291     local(*glob);
 292     while (($sym, *glob) = each %{"main::"}) {
 293         #warn "Trying $sym\n";#debug
 294         svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/;
 295     }
 296
 297     # Now do subs in non-main packages given by -u options
 298     map { $search_pack{$_} = 1 } @extra_packages;
 299     walksymtable(\%{"main::"}, "lintcv", sub {
 300         my $package = shift;
 301         $package =~ s/::$//;
 302         #warn "Considering $package\n";#debug
 303         return exists $search_pack{$package};
 304     });
 305 }
 306
 307 sub compile {
 308     my @options = @_;
 309     my ($option, $opt, $arg);
 310     # Turn on default lint checks
 311     for $opt (@default_checks) {
 312         $check{$opt} = 1;
 313     }
 314   OPTION:
 315     while ($option = shift @options) {
 316         if ($option =~ /^-(.)(.*)/) {
 317             $opt = $1;
 318             $arg = $2;
 319         } else {
 320             unshift @options, $option;
 321             last OPTION;
 322         }
 323         if ($opt eq "-" && $arg eq "-") {
 324             shift @options;
 325             last OPTION;
 326         } elsif ($opt eq "D") {
 327             $arg ||= shift @options;
 328             foreach $arg (split(//, $arg)) {
 329                 if ($arg eq "o") {
 330                     B->debug(1);
 331                 } elsif ($arg eq "O") {
 332                     $debug_op = 1;
 333                 }
 334             }
 335         } elsif ($opt eq "u") {
 336             $arg ||= shift @options;
 337             push(@extra_packages, $arg);
 338         }
 339     }
 340     foreach $opt (@default_checks, @options) {
 341         $opt =~ tr/-/_/;
 342         if ($opt eq "all") {
 343             %check = %valid_check;
 344         }
 345         elsif ($opt eq "none") {
 346             %check = ();
 347         }
 348         else {
 349             if ($opt =~ s/^no-//) {
 350                 $check{$opt} = 0;
 351             }
 352             else {
 353                 $check{$opt} = 1;
 354             }
 355             warn "No such check: $opt\n" unless defined $valid_check{$opt};
 356         }
 357     }
 358     # Remaining arguments are things to check
 359
 360     return \&do_lint;
 361 }
 362
 363 1;