<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package B::Lint;

=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&lt;-w&gt;
option of B&lt;perl&gt;. It is named after the program B&lt;lint&gt; 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&lt;-&gt;) come lint check arguments. Each such
argument (apart from the special B&lt;all&gt; and B&lt;none&gt; options) is a
word representing one possible lint check (turning on that check) or
is B&lt;no-foo&gt; (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&lt;context&gt;

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

    $foo = scalar(@bar);

=item B&lt;implicit-read&gt; and B&lt;implicit-write&gt;

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

    /foo/;

and B&lt;implicit-write&gt; will warn about these:

    s/foo/bar/;

Both B&lt;implicit-read&gt; and B&lt;implicit-write&gt; warn about this:

    for (@a) { ... }

=item B&lt;dollar-underscore&gt;

This option warns whenever $_ is used either explicitly anywhere or
as the implicit argument of a B&lt;print&gt; statement.

=item B&lt;private-names&gt;

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

=item B&lt;undefined-subs&gt;

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

=item B&lt;regexp-variables&gt;

This option warns whenever one of the regexp variables $', $&amp; or
$' is used. Any occurrence of any of these variables in your
program can slow your whole program down. See L&lt;perlre&gt; for
details.

=item B&lt;all&gt;

Turn all warnings on.

=item B&lt;none&gt;

Turn all warnings off.

=back

=head1 NON LINT-CHECK OPTIONS

=over 8

=item B&lt;-u Package&gt;

Normally, Lint only checks the main code of the program together
with all subs defined in package main. The B&lt;-u&gt; option lets you
include other package names whose subs are then checked by Lint.

=back

=head1 BUGS

This is only a very preliminary version.

=head1 AUTHOR

Malcolm Beattie, mbeattie@sable.ox.ac.uk.

=cut

use strict;
use B qw(walkoptree main_root walksymtable svref_2object parents
         OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
        );

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 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 = (@_ &lt; 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-&gt;flags;
    if ($flags &amp; OPf_WANT) {
	return(($flags &amp; OPf_WANT_LIST) ? 1 : 0);
    }
    return undef;
}

sub B::OP::lint {}

sub B::COP::lint {
    my $op = shift;
    if ($op-&gt;name eq "nextstate") {
	$file = $op-&gt;file;
	$line = $op-&gt;line;
	$curstash = $op-&gt;stash-&gt;NAME;
    }
}

sub B::UNOP::lint {
    my $op = shift;
    my $opname = $op-&gt;name;
    if ($check{context} &amp;&amp; ($opname eq "rv2av" || $opname eq "rv2hv")) {
	my $parent = parents-&gt;[0];
	my $pname = $parent-&gt;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-&gt;[1]-&gt;name;
	    return if $gpname eq "enteriter" || $gpname eq "delete";
	}
	warning("Implicit scalar context for %s in %s",
		$opname eq "rv2av" ? "array" : "hash", $parent-&gt;desc);
    }
    if ($check{private_names} &amp;&amp; $opname eq "method") {
	my $methop = $op-&gt;first;
	if ($methop-&gt;name eq "const") {
	    my $method = $methop-&gt;sv-&gt;PV;
	    if ($method =~ /^_/ &amp;&amp; !defined(&amp;{"$curstash\::$method"})) {
		warning("Illegal reference to private method name $method");
	    }
	}
    }
}

sub B::PMOP::lint {
    my $op = shift;
    if ($check{implicit_read}) {
	if ($op-&gt;name eq "match" &amp;&amp; !($op-&gt;flags &amp; OPf_STACKED)) {
	    warning('Implicit match on $_');
	}
    }
    if ($check{implicit_write}) {
	if ($op-&gt;name eq "subst" &amp;&amp; !($op-&gt;flags &amp; OPf_STACKED)) {
	    warning('Implicit substitution on $_');
	}
    }
}

sub B::LOOP::lint {
    my $op = shift;
    if ($check{implicit_read} || $check{implicit_write}) {
	if ($op-&gt;name eq "enteriter") {
	    my $last = $op-&gt;last;
	    if ($last-&gt;name eq "gv" &amp;&amp; $last-&gt;gv-&gt;NAME eq "_") {
		warning('Implicit use of $_ in foreach');
	    }
	}
    }
}

sub B::SVOP::lint {
    my $op = shift;
    if ($check{dollar_underscore} &amp;&amp; $op-&gt;name eq "gvsv"
	&amp;&amp; $op-&gt;gv-&gt;NAME eq "_")
    {
	warning('Use of $_');
    }
    if ($check{private_names}) {
	my $opname = $op-&gt;name;
	if ($opname eq "gv" || $opname eq "gvsv") {
	    my $gv = $op-&gt;gv;
	    if ($gv-&gt;NAME =~ /^_./ &amp;&amp; $gv-&gt;STASH-&gt;NAME ne $curstash) {
		warning('Illegal reference to private name %s', $gv-&gt;NAME);
	    }
	}
    }
    if ($check{undefined_subs}) {
	if ($op-&gt;name eq "gv"
	    &amp;&amp; $op-&gt;next-&gt;name eq "entersub")
	{
	    my $gv = $op-&gt;gv;
	    my $subname = $gv-&gt;STASH-&gt;NAME . "::" . $gv-&gt;NAME;
	    no strict 'refs';
	    if (!defined(&amp;$subname)) {
		$subname =~ s/^main:://;
		warning('Undefined subroutine %s called', $subname);
	    }
	}
    }
    if ($check{regexp_variables} &amp;&amp; $op-&gt;name eq "gvsv") {
	my $name = $op-&gt;gv-&gt;NAME;
	if ($name =~ /^[&amp;'`]$/) {
	    warning('Use of regexp variable $%s', $name);
	}
    }
}

sub B::GV::lintcv {
    my $gv = shift;
    my $cv = $gv-&gt;CV;
    #warn sprintf("lintcv: %s::%s (done=%d)\n",
    #		 $gv-&gt;STASH-&gt;NAME, $gv-&gt;NAME, $done_cv{$$cv});#debug
    return if !$$cv || $done_cv{$$cv}++;
    my $root = $cv-&gt;ROOT;
    #warn "    root = $root (0x$$root)\n";#debug
    walkoptree($root, "lint") if $$root;
}

sub do_lint {
    my %search_pack;
    walkoptree(main_root, "lint") if ${main_root()};
    
    # 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)-&gt;EGV-&gt;lintcv unless $sym =~ /::$/;
    }

    # 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 "-" &amp;&amp; $arg eq "-") {
	    shift @options;
	    last OPTION;
	} elsif ($opt eq "D") {
            $arg ||= shift @options;
	    foreach $arg (split(//, $arg)) {
		if ($arg eq "o") {
		    B-&gt;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 \&amp;do_lint;
}

1;
</pre></body></html>