[p5sagit/p5-mst-13.2.git] / ext / B / B / Lint.pm

package B::Lint;

our $VERSION = '1.01';

=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 B<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<dollar-underscore>

This option warns whenever $_ 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 @_).

=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 $', $& or
$' 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.

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

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 = (@_ < 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{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);
	    }
	}
    }
    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);
    my $sym;
    local(*glob);
    while (($sym, *glob) = each %{"main::"}) {
	#warn "Trying $sym\n";#debug
	svref_2object(\*glob)->EGV->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 "-" && $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;
Commit	Line	Data
a798dbf2	1	package B::Lint;
a798dbf2	2
1f01d156	3	our $VERSION = '1.01';
28b605d8	4
a798dbf2	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 B<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	will elicit a warning. Using an explicit B<scalar()> silences the
	40	warning. For example,
	41
	42	$foo = scalar(@bar);
	43
	44	=item B<implicit-read> and B<implicit-write>
	45
	46	These options produce a warning whenever an operation implicitly
	47	reads or (respectively) writes to one of Perl's special variables.
	48	For example, B<implicit-read> will warn about these:
	49
	50	/foo/;
	51
	52	and B<implicit-write> will warn about these:
	53
	54	s/foo/bar/;
	55
	56	Both B<implicit-read> and B<implicit-write> warn about this:
	57
	58	for (@a) { ... }
	59
	60	=item B<dollar-underscore>
	61
	62	This option warns whenever $_ is used either explicitly anywhere or
	63	as the implicit argument of a B<print> statement.
	64
	65	=item B<private-names>
	66
	67	This option warns on each use of any variable, subroutine or
	68	method name that lives in a non-current package but begins with
69	an underscore ("_"). Warnings aren't issued for the special case
70	of the single character name "_" by itself (e.g. $_ and @_).
71
72	=item B<undefined-subs>
73
74	This option warns whenever an undefined subroutine is invoked.
75	This option will only catch explicitly invoked subroutines such
76	as C<foo()> and not indirect invocations such as C<&$subref()>
77	or C<$obj-E<gt>meth()>. Note that some programs or modules delay
78	definition of subs until runtime by means of the AUTOLOAD
79	mechanism.
80
81	=item B<regexp-variables>
82
83	This option warns whenever one of the regexp variables $', $& or
84	$' is used. Any occurrence of any of these variables in your
85	program can slow your whole program down. See L<perlre> for
86	details.
87
88	=item B<all>
89
90	Turn all warnings on.
91
92	=item B<none>
93
94	Turn all warnings off.
95
96	=back
97
98	=head1 NON LINT-CHECK OPTIONS
99
100	=over 8
101
102	=item B<-u Package>
103
104	Normally, Lint only checks the main code of the program together
105	with all subs defined in package main. The B<-u> option lets you
106	include other package names whose subs are then checked by Lint.
107
108	=back
109
110	=head1 BUGS
111
112	This is only a very preliminary version.
113
114	=head1 AUTHOR
115
116	Malcolm Beattie, mbeattie@sable.ox.ac.uk.
117
118	=cut
119
120	use strict;
b0a2b4f5	121	use B qw(walkoptree_slow main_root walksymtable svref_2object parents
4c1f658f	122	OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
4c1f658f	123	);
a798dbf2	124
	125	my $file = "unknown"; # shadows current filename
	126	my $line = 0; # shadows current line number
	127	my $curstash = "main"; # shadows current stash
	128
	129	# Lint checks
	130	my %check;
	131	my %implies_ok_context;
	132	BEGIN {
	133	map($implies_ok_context{$_}++,
3f872cb9	134	qw(scalar av2arylen aelem aslice helem hslice
3f872cb9	135	keys values hslice defined undef delete));
a798dbf2	136	}
	137
	138	# Lint checks turned on by default
	139	my @default_checks = qw(context);
	140
	141	my %valid_check;
	142	# All valid checks
	143	BEGIN {
	144	map($valid_check{$_}++,
	145	qw(context implicit_read implicit_write dollar_underscore
	146	private_names undefined_subs regexp_variables));
	147	}
	148
	149	# Debugging options
	150	my ($debug_op);
	151
	152	my %done_cv; # used to mark which subs have already been linted
	153	my @extra_packages; # Lint checks mainline code and all subs which are
	154	# in main:: or in one of these packages.
	155
	156	sub warning {
	157	my $format = (@_ < 2) ? "%s" : shift;
	158	warn sprintf("$format at %s line %d\n", @_, $file, $line);
	159	}
	160
	161	# This gimme can't cope with context that's only determined
	162	# at runtime via dowantarray().
	163	sub gimme {
	164	my $op = shift;
	165	my $flags = $op->flags;
4c1f658f	166	if ($flags & OPf_WANT) {
1f01d156	167	return(($flags & OPf_WANT == OPf_WANT_LIST) ? 1 : 0);
a798dbf2	168	}
	169	return undef;
	170	}
	171
	172	sub B::OP::lint {}
	173
	174	sub B::COP::lint {
	175	my $op = shift;
3f872cb9	176	if ($op->name eq "nextstate") {
57843af0	177	$file = $op->file;
a798dbf2	178	$line = $op->line;
	179	$curstash = $op->stash->NAME;
	180	}
	181	}
	182
	183	sub B::UNOP::lint {
	184	my $op = shift;
3f872cb9	185	my $opname = $op->name;
3f872cb9	186	if ($check{context} && ($opname eq "rv2av" \|\| $opname eq "rv2hv")) {
a798dbf2	187	my $parent = parents->[0];
3f872cb9	188	my $pname = $parent->name;
a798dbf2	189	return if gimme($op) \|\| $implies_ok_context{$pname};
	190	# Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
	191	# null out the parent so we have to check for a parent of pp_null and
	192	# a grandparent of pp_enteriter or pp_delete
3f872cb9	193	if ($pname eq "null") {
	194	my $gpname = parents->[1]->name;
	195	return if $gpname eq "enteriter" \|\| $gpname eq "delete";
a798dbf2	196	}
a798dbf2	197	warning("Implicit scalar context for %s in %s",
3f872cb9	198	$opname eq "rv2av" ? "array" : "hash", $parent->desc);
a798dbf2	199	}
3f872cb9	200	if ($check{private_names} && $opname eq "method") {
a798dbf2	201	my $methop = $op->first;
3f872cb9	202	if ($methop->name eq "const") {
a798dbf2	203	my $method = $methop->sv->PV;
	204	if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
	205	warning("Illegal reference to private method name $method");
	206	}
	207	}
	208	}
	209	}
	210
	211	sub B::PMOP::lint {
	212	my $op = shift;
	213	if ($check{implicit_read}) {
3f872cb9	214	if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
a798dbf2	215	warning('Implicit match on $_');
	216	}
	217	}
	218	if ($check{implicit_write}) {
3f872cb9	219	if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
a798dbf2	220	warning('Implicit substitution on $_');
	221	}
	222	}
	223	}
	224
	225	sub B::LOOP::lint {
	226	my $op = shift;
	227	if ($check{implicit_read} \|\| $check{implicit_write}) {
3f872cb9	228	if ($op->name eq "enteriter") {
a798dbf2	229	my $last = $op->last;
3f872cb9	230	if ($last->name eq "gv" && $last->gv->NAME eq "_") {
a798dbf2	231	warning('Implicit use of $_ in foreach');
	232	}
	233	}
	234	}
	235	}
	236
7934575e	237	sub B::SVOP::lint {
a798dbf2	238	my $op = shift;
3f872cb9	239	if ($check{dollar_underscore} && $op->name eq "gvsv"
a798dbf2	240	&& $op->gv->NAME eq "_")
	241	{
	242	warning('Use of $_');
	243	}
	244	if ($check{private_names}) {
3f872cb9	245	my $opname = $op->name;
4f25aa18	246	if ($opname eq "gv" \|\| $opname eq "gvsv") {
7934575e	247	my $gv = $op->gv;
	248	if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
	249	warning('Illegal reference to private name %s', $gv->NAME);
	250	}
a798dbf2	251	}
	252	}
	253	if ($check{undefined_subs}) {
3f872cb9	254	if ($op->name eq "gv"
	255	&& $op->next->name eq "entersub")
	256	{
a798dbf2	257	my $gv = $op->gv;
	258	my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
	259	no strict 'refs';
	260	if (!defined(&$subname)) {
	261	$subname =~ s/^main:://;
	262	warning('Undefined subroutine %s called', $subname);
	263	}
	264	}
	265	}
3f872cb9	266	if ($check{regexp_variables} && $op->name eq "gvsv") {
a798dbf2	267	my $name = $op->gv->NAME;
	268	if ($name =~ /^[&'`]$/) {
	269	warning('Use of regexp variable $%s', $name);
	270	}
	271	}
	272	}
	273
	274	sub B::GV::lintcv {
	275	my $gv = shift;
	276	my $cv = $gv->CV;
	277	#warn sprintf("lintcv: %s::%s (done=%d)\n",
	278	# $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
	279	return if !$$cv \|\| $done_cv{$$cv}++;
	280	my $root = $cv->ROOT;
	281	#warn " root = $root (0x$$root)\n";#debug
b0a2b4f5	282	walkoptree_slow($root, "lint") if $$root;
a798dbf2	283	}
	284
	285	sub do_lint {
	286	my %search_pack;
b0a2b4f5	287	walkoptree_slow(main_root, "lint") if ${main_root()};
a798dbf2	288
	289	# Now do subs in main
	290	no strict qw(vars refs);
	291	my $sym;
	292	local(*glob);
	293	while (($sym, *glob) = each %{"main::"}) {
	294	#warn "Trying $sym\n";#debug
	295	svref_2object(\*glob)->EGV->lintcv unless $sym =~ /::$/;
	296	}
	297
	298	# Now do subs in non-main packages given by -u options
	299	map { $search_pack{$_} = 1 } @extra_packages;
	300	walksymtable(\%{"main::"}, "lintcv", sub {
	301	my $package = shift;
	302	$package =~ s/::$//;
	303	#warn "Considering $package\n";#debug
	304	return exists $search_pack{$package};
	305	});
	306	}
	307
	308	sub compile {
	309	my @options = @_;
	310	my ($option, $opt, $arg);
	311	# Turn on default lint checks
	312	for $opt (@default_checks) {
	313	$check{$opt} = 1;
	314	}
	315	OPTION:
	316	while ($option = shift @options) {
	317	if ($option =~ /^-(.)(.*)/) {
	318	$opt = $1;
	319	$arg = $2;
	320	} else {
	321	unshift @options, $option;
	322	last OPTION;
	323	}
	324	if ($opt eq "-" && $arg eq "-") {
	325	shift @options;
	326	last OPTION;
	327	} elsif ($opt eq "D") {
	328	$arg \|\|= shift @options;
	329	foreach $arg (split(//, $arg)) {
	330	if ($arg eq "o") {
	331	B->debug(1);
	332	} elsif ($arg eq "O") {
	333	$debug_op = 1;
	334	}
	335	}
	336	} elsif ($opt eq "u") {
	337	$arg \|\|= shift @options;
	338	push(@extra_packages, $arg);
	339	}
	340	}
	341	foreach $opt (@default_checks, @options) {
	342	$opt =~ tr/-/_/;
	343	if ($opt eq "all") {
	344	%check = %valid_check;
	345	}
	346	elsif ($opt eq "none") {
	347	%check = ();
	348	}
	349	else {
7f0faf35	350	if ($opt =~ s/^no_//) {
a798dbf2	351	$check{$opt} = 0;
	352	}
	353	else {
	354	$check{$opt} = 1;
	355	}
	356	warn "No such check: $opt\n" unless defined $valid_check{$opt};
	357	}
	358	}
	359	# Remaining arguments are things to check
	360
	361	return \&do_lint;
	362	}
	363
	364	1;