ext/B/B/Lint.pm

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