[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / 5.8.0 / sun4-solaris / 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.

This module doesn't work correctly on thread-enabled perls.

=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);
	    }
	} 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;
Commit	Line	Data
86530b38 AT	1	package B::Lint;
	2
	3	our $VERSION = '1.01';
	4
	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	This module doesn't work correctly on thread-enabled perls.
115
116	=head1 AUTHOR
117
118	Malcolm Beattie, mbeattie@sable.ox.ac.uk.
119
120	=cut
121
122	use strict;
123	use B qw(walkoptree_slow main_root walksymtable svref_2object parents
124	OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY
125	);
126
127	my $file = "unknown"; # shadows current filename
128	my $line = 0; # shadows current line number
129	my $curstash = "main"; # shadows current stash
130
131	# Lint checks
132	my %check;
133	my %implies_ok_context;
134	BEGIN {
135	map($implies_ok_context{$_}++,
136	qw(scalar av2arylen aelem aslice helem hslice
137	keys values hslice defined undef delete));
138	}
139
140	# Lint checks turned on by default
141	my @default_checks = qw(context);
142
143	my %valid_check;
144	# All valid checks
145	BEGIN {
146	map($valid_check{$_}++,
147	qw(context implicit_read implicit_write dollar_underscore
148	private_names undefined_subs regexp_variables));
149	}
150
151	# Debugging options
152	my ($debug_op);
153
154	my %done_cv; # used to mark which subs have already been linted
155	my @extra_packages; # Lint checks mainline code and all subs which are
156	# in main:: or in one of these packages.
157
158	sub warning {
159	my $format = (@_ < 2) ? "%s" : shift;
160	warn sprintf("$format at %s line %d\n", @_, $file, $line);
161	}
162
163	# This gimme can't cope with context that's only determined
164	# at runtime via dowantarray().
165	sub gimme {
166	my $op = shift;
167	my $flags = $op->flags;
168	if ($flags & OPf_WANT) {
169	return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
170	}
171	return undef;
172	}
173
174	sub B::OP::lint {}
175
176	sub B::COP::lint {
177	my $op = shift;
178	if ($op->name eq "nextstate") {
179	$file = $op->file;
180	$line = $op->line;
181	$curstash = $op->stash->NAME;
182	}
183	}
184
185	sub B::UNOP::lint {
186	my $op = shift;
187	my $opname = $op->name;
188	if ($check{context} && ($opname eq "rv2av" \|\| $opname eq "rv2hv")) {
189	my $parent = parents->[0];
190	my $pname = $parent->name;
191	return if gimme($op) \|\| $implies_ok_context{$pname};
192	# Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
193	# null out the parent so we have to check for a parent of pp_null and
194	# a grandparent of pp_enteriter or pp_delete
195	if ($pname eq "null") {
196	my $gpname = parents->[1]->name;
197	return if $gpname eq "enteriter" \|\| $gpname eq "delete";
198	}
199	warning("Implicit scalar context for %s in %s",
200	$opname eq "rv2av" ? "array" : "hash", $parent->desc);
201	}
202	if ($check{private_names} && $opname eq "method") {
203	my $methop = $op->first;
204	if ($methop->name eq "const") {
205	my $method = $methop->sv->PV;
206	if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
207	warning("Illegal reference to private method name $method");
208	}
209	}
210	}
211	}
212
213	sub B::PMOP::lint {
214	my $op = shift;
215	if ($check{implicit_read}) {
216	if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
217	warning('Implicit match on $_');
218	}
219	}
220	if ($check{implicit_write}) {
221	if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
222	warning('Implicit substitution on $_');
223	}
224	}
225	}
226
227	sub B::LOOP::lint {
228	my $op = shift;
229	if ($check{implicit_read} \|\| $check{implicit_write}) {
230	if ($op->name eq "enteriter") {
231	my $last = $op->last;
232	if ($last->name eq "gv" && $last->gv->NAME eq "_") {
233	warning('Implicit use of $_ in foreach');
234	}
235	}
236	}
237	}
238
239	sub B::SVOP::lint {
240	my $op = shift;
241	if ($check{dollar_underscore} && $op->name eq "gvsv"
242	&& $op->gv->NAME eq "_")
243	{
244	warning('Use of $_');
245	}
246	if ($check{private_names}) {
247	my $opname = $op->name;
248	if ($opname eq "gv" \|\| $opname eq "gvsv") {
249	my $gv = $op->gv;
250	if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
251	warning('Illegal reference to private name %s', $gv->NAME);
252	}
253	} elsif ($opname eq "method_named") {
254	my $method = $op->gv->PV;
255	if ($method =~ /^_./) {
256	warning("Illegal reference to private method name $method");
257	}
258	}
259	}
260	if ($check{undefined_subs}) {
261	if ($op->name eq "gv"
262	&& $op->next->name eq "entersub")
263	{
264	my $gv = $op->gv;
265	my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
266	no strict 'refs';
267	if (!defined(&$subname)) {
268	$subname =~ s/^main:://;
269	warning('Undefined subroutine %s called', $subname);
270	}
271	}
272	}
273	if ($check{regexp_variables} && $op->name eq "gvsv") {
274	my $name = $op->gv->NAME;
275	if ($name =~ /^[&'`]$/) {
276	warning('Use of regexp variable $%s', $name);
277	}
278	}
279	}
280
281	sub B::GV::lintcv {
282	my $gv = shift;
283	my $cv = $gv->CV;
284	#warn sprintf("lintcv: %s::%s (done=%d)\n",
285	# $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
286	return if !$$cv \|\| $done_cv{$$cv}++;
287	my $root = $cv->ROOT;
288	#warn " root = $root (0x$$root)\n";#debug
289	walkoptree_slow($root, "lint") if $$root;
290	}
291
292	sub do_lint {
293	my %search_pack;
294	walkoptree_slow(main_root, "lint") if ${main_root()};
295
296	# Now do subs in main
297	no strict qw(vars refs);
298	local(*glob);
299	for my $sym (keys %main::) {
300	next if $sym =~ /::$/;
301	*glob = $main::{$sym};
302	svref_2object(\*glob)->EGV->lintcv;
303	}
304
305	# Now do subs in non-main packages given by -u options
306	map { $search_pack{$_} = 1 } @extra_packages;
307	walksymtable(\%{"main::"}, "lintcv", sub {
308	my $package = shift;
309	$package =~ s/::$//;
310	#warn "Considering $package\n";#debug
311	return exists $search_pack{$package};
312	});
313	}
314
315	sub compile {
316	my @options = @_;
317	my ($option, $opt, $arg);
318	# Turn on default lint checks
319	for $opt (@default_checks) {
320	$check{$opt} = 1;
321	}
322	OPTION:
323	while ($option = shift @options) {
324	if ($option =~ /^-(.)(.*)/) {
325	$opt = $1;
326	$arg = $2;
327	} else {
328	unshift @options, $option;
329	last OPTION;
330	}
331	if ($opt eq "-" && $arg eq "-") {
332	shift @options;
333	last OPTION;
334	} elsif ($opt eq "D") {
335	$arg \|\|= shift @options;
336	foreach $arg (split(//, $arg)) {
337	if ($arg eq "o") {
338	B->debug(1);
339	} elsif ($arg eq "O") {
340	$debug_op = 1;
341	}
342	}
343	} elsif ($opt eq "u") {
344	$arg \|\|= shift @options;
345	push(@extra_packages, $arg);
346	}
347	}
348	foreach $opt (@default_checks, @options) {
349	$opt =~ tr/-/_/;
350	if ($opt eq "all") {
351	%check = %valid_check;
352	}
353	elsif ($opt eq "none") {
354	%check = ();
355	}
356	else {
357	if ($opt =~ s/^no_//) {
358	$check{$opt} = 0;
359	}
360	else {
361	$check{$opt} = 1;
362	}
363	warn "No such check: $opt\n" unless defined $valid_check{$opt};
364	}
365	}
366	# Remaining arguments are things to check
367
368	return \&do_lint;
369	}
370
371	1;