source: for-distributions/trunk/bin/windows/perl/lib/B/Lint.pm@ 14489

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<perl>. It is named after the program F<lint> 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<all> and B<none> options) is a
word representing one possible lint check (turning on that check) or
is B<no-foo> (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<context>

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<scalar()> silences the
warning. For example,

    $foo = scalar(@bar);

=item B<implicit-read> and B<implicit-write>

These options produce a warning whenever an operation implicitly
reads or (respectively) writes to one of Perl's special variables.
For example, B<implicit-read> will warn about these:

    /foo/;

and B<implicit-write> will warn about these:

    s/foo/bar/;

Both B<implicit-read> and B<implicit-write> warn about this:

    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 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. C<$_> and C<@_>).

=item B<undefined-subs>

This option warns whenever an undefined subroutine is invoked.
This option will only catch explicitly invoked subroutines such
as C<foo()> and not indirect invocations such as C<&$subref()>
or C<$obj-E<gt>meth()>. Note that some programs or modules delay
definition of subs until runtime by means of the AUTOLOAD
mechanism.

=item B<regexp-variables>

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.

=item B<all>

Turn all warnings on.

=item B<none>

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, [email protected].

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