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

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