tlperl: Perl for scripts provided by TeX Live.

git-svn-id: svn://tug.org/texlive/trunk@6046 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 392 insertions, 0 deletions

diff --git a/Master/tlpkg/tlperl/lib/B/Lint.pm b/Master/tlpkg/tlperl/lib/B/Lint.pm
new file mode 100644
index 00000000000..3475bd2596e
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Lint.pm
@@ -0,0 +1,392 @@
+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, 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 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;