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 This module doesn't work correctly on thread-enabled perls.
 115
 116 =head1 AUTHOR
 117
 118 Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 119
 120 =cut
 121
 122 use strict;
 123 use B qw(walkoptree_slow main_root walksymtable svref_2object parents
 124          OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
 125         );
 126
 127 my $file = "unknown";           # shadows current filename
 128 my $line = 0;                   # shadows current line number
 129 my $curstash = "main";          # shadows current stash
 130
 131 # Lint checks
 132 my %check;
 133 my %implies_ok_context;
 134 BEGIN {
 135     map($implies_ok_context{$_}++,
 136         qw(scalar av2arylen aelem aslice helem hslice
 137            keys values hslice defined undef delete));
 138 }
 139
 140 # Lint checks turned on by default
 141 my @default_checks = qw(context);
 142
 143 my %valid_check;
 144 # All valid checks
 145 BEGIN {
 146     map($valid_check{$_}++,
 147         qw(context implicit_read implicit_write dollar_underscore
 148            private_names undefined_subs regexp_variables));
 149 }
 150
 151 # Debugging options
 152 my ($debug_op);
 153
 154 my %done_cv;            # used to mark which subs have already been linted
 155 my @extra_packages;     # Lint checks mainline code and all subs which are
 156                         # in main:: or in one of these packages.
 157
 158 sub warning {
 159     my $format = (@_ < 2) ? "%s" : shift;
 160     warn sprintf("$format at %s line %d\n", @_, $file, $line);
 161 }
 162
 163 # This gimme can't cope with context that's only determined
 164 # at runtime via dowantarray().
 165 sub gimme {
 166     my $op = shift;
 167     my $flags = $op->flags;
 168     if ($flags & OPf_WANT) {
 169         return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
 170     }
 171     return undef;
 172 }
 173
 174 sub B::OP::lint {}
 175
 176 sub B::COP::lint {
 177     my $op = shift;
 178     if ($op->name eq "nextstate") {
 179         $file = $op->file;
 180         $line = $op->line;
 181         $curstash = $op->stash->NAME;
 182     }
 183 }
 184
 185 sub B::UNOP::lint {
 186     my $op = shift;
 187     my $opname = $op->name;
 188     if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
 189         my $parent = parents->[0];
 190         my $pname = $parent->name;
 191         return if gimme($op) || $implies_ok_context{$pname};
 192         # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
 193         # null out the parent so we have to check for a parent of pp_null and
 194         # a grandparent of pp_enteriter or pp_delete
 195         if ($pname eq "null") {
 196             my $gpname = parents->[1]->name;
 197             return if $gpname eq "enteriter" || $gpname eq "delete";
 198         }
 199         warning("Implicit scalar context for %s in %s",
 200                 $opname eq "rv2av" ? "array" : "hash", $parent->desc);
 201     }
 202     if ($check{private_names} && $opname eq "method") {
 203         my $methop = $op->first;
 204         if ($methop->name eq "const") {
 205             my $method = $methop->sv->PV;
 206             if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
 207                 warning("Illegal reference to private method name $method");
 208             }
 209         }
 210     }
 211 }
 212
 213 sub B::PMOP::lint {
 214     my $op = shift;
 215     if ($check{implicit_read}) {
 216         if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
 217             warning('Implicit match on $_');
 218         }
 219     }
 220     if ($check{implicit_write}) {
 221         if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
 222             warning('Implicit substitution on $_');
 223         }
 224     }
 225 }
 226
 227 sub B::LOOP::lint {
 228     my $op = shift;
 229     if ($check{implicit_read} || $check{implicit_write}) {
 230         if ($op->name eq "enteriter") {
 231             my $last = $op->last;
 232             if ($last->name eq "gv" && $last->gv->NAME eq "_") {
 233                 warning('Implicit use of $_ in foreach');
 234             }
 235         }
 236     }
 237 }
 238
 239 sub B::SVOP::lint {
 240     my $op = shift;
 241     if ($check{dollar_underscore} && $op->name eq "gvsv"
 242         && $op->gv->NAME eq "_")
 243     {
 244         warning('Use of $_');
 245     }
 246     if ($check{private_names}) {
 247         my $opname = $op->name;
 248         if ($opname eq "gv" || $opname eq "gvsv") {
 249             my $gv = $op->gv;
 250             if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
 251                 warning('Illegal reference to private name %s', $gv->NAME);
 252             }
 253         }
 254     }
 255     if ($check{undefined_subs}) {
 256         if ($op->name eq "gv"
 257             && $op->next->name eq "entersub")
 258         {
 259             my $gv = $op->gv;
 260             my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
 261             no strict 'refs';
 262             if (!defined(&$subname)) {
 263                 $subname =~ s/^main:://;
 264                 warning('Undefined subroutine %s called', $subname);
 265             }
 266         }
 267     }
 268     if ($check{regexp_variables} && $op->name eq "gvsv") {
 269         my $name = $op->gv->NAME;
 270         if ($name =~ /^[&'`]$/) {
 271             warning('Use of regexp variable $%s', $name);
 272         }
 273     }
 274 }
 275
 276 sub B::GV::lintcv {
 277     my $gv = shift;
 278     my $cv = $gv->CV;
 279     #warn sprintf("lintcv: %s::%s (done=%d)\n",
 280     #            $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
 281     return if !$$cv || $done_cv{$$cv}++;
 282     my $root = $cv->ROOT;
 283     #warn "    root = $root (0x$$root)\n";#debug
 284     walkoptree_slow($root, "lint") if $$root;
 285 }
 286
 287 sub do_lint {
 288     my %search_pack;
 289     walkoptree_slow(main_root, "lint") if ${main_root()};
 290
 291     # Now do subs in main
 292     no strict qw(vars refs);
 293     local(*glob);
 294     for my $sym (keys %main::) {
 295         next if $sym =~ /::$/;
 296         *glob = $main::{$sym};
 297         svref_2object(\*glob)->EGV->lintcv;
 298     }
 299
 300     # Now do subs in non-main packages given by -u options
 301     map { $search_pack{$_} = 1 } @extra_packages;
 302     walksymtable(\%{"main::"}, "lintcv", sub {
 303         my $package = shift;
 304         $package =~ s/::$//;
 305         #warn "Considering $package\n";#debug
 306         return exists $search_pack{$package};
 307     });
 308 }
 309
 310 sub compile {
 311     my @options = @_;
 312     my ($option, $opt, $arg);
 313     # Turn on default lint checks
 314     for $opt (@default_checks) {
 315         $check{$opt} = 1;
 316     }
 317   OPTION:
 318     while ($option = shift @options) {
 319         if ($option =~ /^-(.)(.*)/) {
 320             $opt = $1;
 321             $arg = $2;
 322         } else {
 323             unshift @options, $option;
 324             last OPTION;
 325         }
 326         if ($opt eq "-" && $arg eq "-") {
 327             shift @options;
 328             last OPTION;
 329         } elsif ($opt eq "D") {
 330             $arg ||= shift @options;
 331             foreach $arg (split(//, $arg)) {
 332                 if ($arg eq "o") {
 333                     B->debug(1);
 334                 } elsif ($arg eq "O") {
 335                     $debug_op = 1;
 336                 }
 337             }
 338         } elsif ($opt eq "u") {
 339             $arg ||= shift @options;
 340             push(@extra_packages, $arg);
 341         }
 342     }
 343     foreach $opt (@default_checks, @options) {
 344         $opt =~ tr/-/_/;
 345         if ($opt eq "all") {
 346             %check = %valid_check;
 347         }
 348         elsif ($opt eq "none") {
 349             %check = ();
 350         }
 351         else {
 352             if ($opt =~ s/^no_//) {
 353                 $check{$opt} = 0;
 354             }
 355             else {
 356                 $check{$opt} = 1;
 357             }
 358             warn "No such check: $opt\n" unless defined $valid_check{$opt};
 359         }
 360     }
 361     # Remaining arguments are things to check
 362
 363     return \&do_lint;
 364 }
 365
 366 1;