| 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; |