package B::Lint;
+our $VERSION = '1.04';
+
=head1 NAME
B::Lint - Perl lint
=head1 DESCRIPTION
The B::Lint module is equivalent to an extended version of the B<-w>
-option of B<perl>. It is named after the program B<lint> which carries
+option of B<perl>. It is named after the program F<lint> which carries
out a similar process for C programs.
=head1 OPTIONS AND LINT CHECKS
$foo = length(@bar);
$foo = @bar;
+
will elicit a warning. Using an explicit B<scalar()> silences the
warning. For example,
for (@a) { ... }
+=item B<bare-subs>
+
+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<dollar-underscore>
-This option warns whenever $_ is used either explicitly anywhere or
+This option warns whenever C<$_> is used either explicitly anywhere or
as the implicit argument of a B<print> statement.
=item B<private-names>
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. $_ and @_).
+of the single character name "_" by itself (e.g. C<$_> and C<@_>).
=item B<undefined-subs>
=item B<regexp-variables>
-This option warns whenever one of the regexp variables $', $& or
-$' is used. Any occurrence of any of these variables in your
+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<perlre> for
details.
=back
+=head1 EXTENDING LINT
+
+Lint can be extended by registering plugins.
+
+The C<< B::Lint->register_plugin( MyPlugin => \@new_checks ) >> method
+adds the class C<MyPlugin> to the list of plugins. It also adds the
+list of C<@new_checks> to the list of valid checks.
+
+You must create a C<match( \%checks )> method in your plugin class or one
+of its parents. It will be called on every op as a regular method call
+with a hash ref of checks as its parameter.
+
+You may not alter the %checks hash reference.
+
+The class methods C<< B::Lint->file >> and C<< B::Lint->line >> contain
+the current filename and line number.
+
+ package Sample;
+ use B::Lint;
+ B::Lint->register_plugin( Sample => [ 'good_taste' ] );
+
+ sub match {
+ my ( $op, $checks_href ) = shift;
+ if ( $checks_href->{good_taste} ) {
+ ...
+ }
+ }
+
=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.
use strict;
use B qw(walkoptree_slow main_root walksymtable svref_2object parents
- OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
+ class
+ 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
+sub file { $file }
+sub line { $line }
+
# Lint checks
my %check;
my %implies_ok_context;
BEGIN {
map($implies_ok_context{$_}++,
- qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice
- pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete));
+ 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;
+my %plugin_valid_check;
# All valid checks
BEGIN {
map($valid_check{$_}++,
qw(context implicit_read implicit_write dollar_underscore
- private_names undefined_subs regexp_variables));
+ private_names bare_subs undefined_subs regexp_variables));
}
# Debugging options
my $op = shift;
my $flags = $op->flags;
if ($flags & OPf_WANT) {
- return(($flags & OPf_WANT_LIST) ? 1 : 0);
+ return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
}
return undef;
}
-sub B::OP::lint {}
+my @plugins;
+
+sub B::OP::lint {
+ my $op = shift;
+ my $m;
+ $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+ return;
+}
+
+*$_ = *B::OP::lint
+ for \ ( *B::PADOP::lint,
+ *B::LOGOP::lint,
+ *B::BINOP::lint,
+ *B::LISTOP::lint );
sub B::COP::lint {
my $op = shift;
- if ($op->ppaddr eq "pp_nextstate") {
- $file = $op->filegv->SV->PV;
+ if ($op->name eq "nextstate") {
+ $file = $op->file;
$line = $op->line;
$curstash = $op->stash->NAME;
}
+
+ my $m;
+ $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+ return;
}
sub B::UNOP::lint {
my $op = shift;
- my $ppaddr = $op->ppaddr;
- if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) {
+ my $opname = $op->name;
+ if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
my $parent = parents->[0];
- my $pname = $parent->ppaddr;
+ 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 "pp_null") {
- my $gpname = parents->[1]->ppaddr;
- return if $gpname eq "pp_enteriter" || $gpname eq "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",
- $ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc);
+ $opname eq "rv2av" ? "array" : "hash", $parent->desc);
}
- if ($check{private_names} && $ppaddr eq "pp_method") {
+ if ($check{private_names} && $opname eq "method") {
my $methop = $op->first;
- if ($methop->ppaddr eq "pp_const") {
+ if ($methop->name eq "const") {
my $method = $methop->sv->PV;
if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
warning("Illegal reference to private method name $method");
}
}
}
+
+ my $m;
+ $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+ return;
}
sub B::PMOP::lint {
my $op = shift;
if ($check{implicit_read}) {
- my $ppaddr = $op->ppaddr;
- if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) {
+ if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
warning('Implicit match on $_');
}
}
if ($check{implicit_write}) {
- my $ppaddr = $op->ppaddr;
- if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) {
+ if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
warning('Implicit substitution on $_');
}
}
+
+ my $m;
+ $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+ return;
}
sub B::LOOP::lint {
my $op = shift;
if ($check{implicit_read} || $check{implicit_write}) {
- my $ppaddr = $op->ppaddr;
- if ($ppaddr eq "pp_enteriter") {
+ if ($op->name eq "enteriter") {
my $last = $op->last;
- if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") {
+ if ($last->name eq "gv" && $last->gv->NAME eq "_") {
warning('Implicit use of $_ in foreach');
}
}
}
+
+ my $m;
+ $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+ return;
}
-sub B::GVOP::lint {
+sub B::SVOP::lint {
my $op = shift;
- if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv"
+ 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 $ppaddr = $op->ppaddr;
- my $gv = $op->gv;
- if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv")
- && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash)
- {
- warning('Illegal reference to private name %s', $gv->NAME);
+ 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->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") {
+ 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 ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") {
+ if ($check{regexp_variables} && $op->name eq "gvsv") {
my $name = $op->gv->NAME;
if ($name =~ /^[&'`]$/) {
warning('Use of regexp variable $%s', $name);
}
}
+
+ my $m;
+ $m = $_->can('match'), $op->$m( \ %check ) for @plugins;
+ return;
}
sub B::GV::lintcv {
# Now do subs in main
no strict qw(vars refs);
- my $sym;
local(*glob);
- while (($sym, *glob) = each %{"main::"}) {
- #warn "Trying $sym\n";#debug
- svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/;
+ for my $sym (keys %main::) {
+ next if $sym =~ /::$/;
+ *glob = $main::{$sym};
+
+ # When is EGV a special value?
+ my $gv = svref_2object(\*glob)->EGV;
+ next if class( $gv ) eq 'SPECIAL';
+ $gv->lintcv;
}
# Now do subs in non-main packages given by -u options
foreach $opt (@default_checks, @options) {
$opt =~ tr/-/_/;
if ($opt eq "all") {
- %check = %valid_check;
+ %check = ( %valid_check, %plugin_valid_check );
}
elsif ($opt eq "none") {
%check = ();
}
else {
- if ($opt =~ s/^no-//) {
+ if ($opt =~ s/^no_//) {
$check{$opt} = 0;
}
else {
$check{$opt} = 1;
}
- warn "No such check: $opt\n" unless defined $valid_check{$opt};
+ warn "No such check: $opt\n" unless defined $valid_check{$opt}
+ or defined $plugin_valid_check{$opt};
}
}
# Remaining arguments are things to check
-
+
return \&do_lint;
}
+sub register_plugin {
+ my ( undef, $plugin, $new_checks ) = @_;
+
+ # Register the plugin
+ for my $check ( @$new_checks ) {
+ defined $check
+ or warn "Undefined value in checks.";
+ not $valid_check{ $check }
+ or warn "$check is already registered as a B::Lint feature.";
+ not $plugin_valid_check{ $check }
+ or warn "$check is already registered as a $plugin_valid_check{$check} feature.";
+
+ $plugin_valid_check{$check} = $plugin;
+ }
+
+ push @plugins, $plugin;
+
+ return;
+}
+
1;
https://perl5.git.perl.org / perl5.git / blobdiff