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