package B::Lint; our $VERSION = '1.03'; =head1 NAME B::Lint - Perl lint =head1 SYNOPSIS perl -MO=Lint[,OPTIONS] foo.pl =head1 DESCRIPTION The B::Lint module is equivalent to an extended version of the B<-w> option of B. It is named after the program F which carries out a similar process for C programs. =head1 OPTIONS AND LINT CHECKS Option words are separated by commas (not whitespace) and follow the usual conventions of compiler backend options. Following any options (indicated by a leading B<->) come lint check arguments. Each such argument (apart from the special B and B options) is a word representing one possible lint check (turning on that check) or is B (turning off that check). Before processing the check arguments, a standard list of checks is turned on. Later options override earlier ones. Available options are: =over 8 =item B Produces a warning whenever an array is used in an implicit scalar context. For example, both of the lines $foo = length(@bar); $foo = @bar; will elicit a warning. Using an explicit B silences the warning. For example, $foo = scalar(@bar); =item B and B These options produce a warning whenever an operation implicitly reads or (respectively) writes to one of Perl's special variables. For example, B will warn about these: /foo/; and B will warn about these: s/foo/bar/; Both B and B warn about this: for (@a) { ... } =item B This option warns whenever a bareword is implicitly quoted, but is also the name of a subroutine in the current package. Typical mistakes that it will trap are: use constant foo => 'bar'; @a = ( foo => 1 ); $b{foo} = 2; Neither of these will do what a naive user would expect. =item B This option warns whenever C<$_> is used either explicitly anywhere or as the implicit argument of a B statement. =item B This option warns on each use of any variable, subroutine or method name that lives in a non-current package but begins with an underscore ("_"). Warnings aren't issued for the special case of the single character name "_" by itself (e.g. C<$_> and C<@_>). =item B This option warns whenever an undefined subroutine is invoked. This option will only catch explicitly invoked subroutines such as C and not indirect invocations such as C<&$subref()> or C<$obj-Emeth()>. Note that some programs or modules delay definition of subs until runtime by means of the AUTOLOAD mechanism. =item B This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'> is used. Any occurrence of any of these variables in your program can slow your whole program down. See L for details. =item B Turn all warnings on. =item B Turn all warnings off. =back =head1 NON LINT-CHECK OPTIONS =over 8 =item B<-u Package> Normally, Lint only checks the main code of the program together with all subs defined in package main. The B<-u> option lets you include other package names whose subs are then checked by Lint. =back =head1 BUGS This is only a very preliminary version. This module doesn't work correctly on thread-enabled perls. =head1 AUTHOR Malcolm Beattie, mbeattie@sable.ox.ac.uk. =cut use strict; use B qw(walkoptree_slow main_root walksymtable svref_2object parents OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK ); my $file = "unknown"; # shadows current filename my $line = 0; # shadows current line number my $curstash = "main"; # shadows current stash # Lint checks my %check; my %implies_ok_context; BEGIN { map($implies_ok_context{$_}++, qw(scalar av2arylen aelem aslice helem hslice keys values hslice defined undef delete)); } # Lint checks turned on by default my @default_checks = qw(context); my %valid_check; # All valid checks BEGIN { map($valid_check{$_}++, qw(context implicit_read implicit_write dollar_underscore private_names bare_subs undefined_subs regexp_variables)); } # Debugging options my ($debug_op); my %done_cv; # used to mark which subs have already been linted my @extra_packages; # Lint checks mainline code and all subs which are # in main:: or in one of these packages. sub warning { my $format = (@_ < 2) ? "%s" : shift; warn sprintf("$format at %s line %d\n", @_, $file, $line); } # This gimme can't cope with context that's only determined # at runtime via dowantarray(). sub gimme { my $op = shift; my $flags = $op->flags; if ($flags & OPf_WANT) { return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0); } return undef; } sub B::OP::lint {} sub B::COP::lint { my $op = shift; if ($op->name eq "nextstate") { $file = $op->file; $line = $op->line; $curstash = $op->stash->NAME; } } sub B::UNOP::lint { my $op = shift; my $opname = $op->name; if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) { my $parent = parents->[0]; my $pname = $parent->name; return if gimme($op) || $implies_ok_context{$pname}; # Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}" # null out the parent so we have to check for a parent of pp_null and # a grandparent of pp_enteriter or pp_delete if ($pname eq "null") { my $gpname = parents->[1]->name; return if $gpname eq "enteriter" || $gpname eq "delete"; } warning("Implicit scalar context for %s in %s", $opname eq "rv2av" ? "array" : "hash", $parent->desc); } if ($check{private_names} && $opname eq "method") { my $methop = $op->first; if ($methop->name eq "const") { my $method = $methop->sv->PV; if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) { warning("Illegal reference to private method name $method"); } } } } sub B::PMOP::lint { my $op = shift; if ($check{implicit_read}) { if ($op->name eq "match" && !($op->flags & OPf_STACKED)) { warning('Implicit match on $_'); } } if ($check{implicit_write}) { if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) { warning('Implicit substitution on $_'); } } } sub B::LOOP::lint { my $op = shift; if ($check{implicit_read} || $check{implicit_write}) { if ($op->name eq "enteriter") { my $last = $op->last; if ($last->name eq "gv" && $last->gv->NAME eq "_") { warning('Implicit use of $_ in foreach'); } } } } sub B::SVOP::lint { my $op = shift; if ( $check{bare_subs} && $op->name eq 'const' && $op->private & 64 ) # OPpCONST_BARE = 64 in op.h { my $sv = $op->sv; if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) { warning "Bare sub name '" . $sv->PV . "' interpreted as string"; } } if ($check{dollar_underscore} && $op->name eq "gvsv" && $op->gv->NAME eq "_") { warning('Use of $_'); } if ($check{private_names}) { my $opname = $op->name; if ($opname eq "gv" || $opname eq "gvsv") { my $gv = $op->gv; if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) { warning('Illegal reference to private name %s', $gv->NAME); } } elsif ($opname eq "method_named") { my $method = $op->gv->PV; if ($method =~ /^_./) { warning("Illegal reference to private method name $method"); } } } if ($check{undefined_subs}) { if ($op->name eq "gv" && $op->next->name eq "entersub") { my $gv = $op->gv; my $subname = $gv->STASH->NAME . "::" . $gv->NAME; no strict 'refs'; if (!defined(&$subname)) { $subname =~ s/^main:://; warning('Undefined subroutine %s called', $subname); } } } if ($check{regexp_variables} && $op->name eq "gvsv") { my $name = $op->gv->NAME; if ($name =~ /^[&'`]$/) { warning('Use of regexp variable $%s', $name); } } } sub B::GV::lintcv { my $gv = shift; my $cv = $gv->CV; #warn sprintf("lintcv: %s::%s (done=%d)\n", # $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug return if !$$cv || $done_cv{$$cv}++; my $root = $cv->ROOT; #warn " root = $root (0x$$root)\n";#debug walkoptree_slow($root, "lint") if $$root; } sub do_lint { my %search_pack; walkoptree_slow(main_root, "lint") if ${main_root()}; # Now do subs in main no strict qw(vars refs); local(*glob); for my $sym (keys %main::) { next if $sym =~ /::$/; *glob = $main::{$sym}; svref_2object(\*glob)->EGV->lintcv; } # Now do subs in non-main packages given by -u options map { $search_pack{$_} = 1 } @extra_packages; walksymtable(\%{"main::"}, "lintcv", sub { my $package = shift; $package =~ s/::$//; #warn "Considering $package\n";#debug return exists $search_pack{$package}; }); } sub compile { my @options = @_; my ($option, $opt, $arg); # Turn on default lint checks for $opt (@default_checks) { $check{$opt} = 1; } OPTION: while ($option = shift @options) { if ($option =~ /^-(.)(.*)/) { $opt = $1; $arg = $2; } else { unshift @options, $option; last OPTION; } if ($opt eq "-" && $arg eq "-") { shift @options; last OPTION; } elsif ($opt eq "D") { $arg ||= shift @options; foreach $arg (split(//, $arg)) { if ($arg eq "o") { B->debug(1); } elsif ($arg eq "O") { $debug_op = 1; } } } elsif ($opt eq "u") { $arg ||= shift @options; push(@extra_packages, $arg); } } foreach $opt (@default_checks, @options) { $opt =~ tr/-/_/; if ($opt eq "all") { %check = %valid_check; } elsif ($opt eq "none") { %check = (); } else { if ($opt =~ s/^no_//) { $check{$opt} = 0; } else { $check{$opt} = 1; } warn "No such check: $opt\n" unless defined $valid_check{$opt}; } } # Remaining arguments are things to check return \&do_lint; } 1;