X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FB%2FB%2FLint.pm;h=3475bd2596e11867bd6c6f7eba624628c23f607d;hb=bb7c595be2e30a806b95ad83e9d3613aeb95c384;hp=d34bd7792bcaaec74b3a42afb29f46dff35c934f;hpb=a798dbf2f5009fe67f7460a594ffd57a76c0fa98;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/ext/B/B/Lint.pm b/ext/B/B/Lint.pm
index d34bd77..3475bd2 100644
--- a/ext/B/B/Lint.pm
+++ b/ext/B/B/Lint.pm
@@ -1,5 +1,7 @@
 package B::Lint;
 
+our $VERSION = '1.03';
+
 =head1 NAME
 
 B::Lint - Perl lint
@@ -11,7 +13,7 @@ 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
+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
@@ -34,6 +36,7 @@ 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,
 
@@ -55,9 +58,21 @@ 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 $_ is used either explicitly anywhere or
+This option warns whenever C<$_> is used either explicitly anywhere or
 as the implicit argument of a B<print> statement.
 
 =item B<private-names>
@@ -65,7 +80,7 @@ as the implicit argument of a B<print> statement.
 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 @_).
+of the single character name "_" by itself (e.g. C<$_> and C<@_>).
 
 =item B<undefined-subs>
 
@@ -78,8 +93,8 @@ 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
+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.
 
@@ -109,6 +124,8 @@ include other package names whose subs are then checked by Lint.
 
 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.
@@ -116,13 +133,9 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 =cut
 
 use strict;
-use B qw(walkoptree_slow main_root walksymtable svref_2object parents);
-
-# Constants (should probably be elsewhere)
-sub G_ARRAY () { 1 }
-sub OPf_LIST () { 1 }
-sub OPf_KNOW () { 2 }
-sub OPf_STACKED () { 64 }
+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
@@ -133,8 +146,8 @@ my %check;
 my %implies_ok_context;
 BEGIN {
     map($implies_ok_context{$_}++,
-	qw(pp_scalar pp_av2arylen pp_aelem pp_aslice pp_helem pp_hslice
-	   pp_keys pp_values pp_hslice pp_defined pp_undef pp_delete));
+	qw(scalar av2arylen aelem aslice helem hslice
+	   keys values hslice defined undef delete));
 }
 
 # Lint checks turned on by default
@@ -145,7 +158,7 @@ my %valid_check;
 BEGIN {
     map($valid_check{$_}++,
 	qw(context implicit_read implicit_write dollar_underscore
-	   private_names undefined_subs regexp_variables));
+	   private_names bare_subs undefined_subs regexp_variables));
 }
 
 # Debugging options
@@ -165,8 +178,8 @@ sub warning {
 sub gimme {
     my $op = shift;
     my $flags = $op->flags;
-    if ($flags & OPf_KNOW) {
-	return(($flags & OPf_LIST) ? 1 : 0);
+    if ($flags & OPf_WANT) {
+	return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
     }
     return undef;
 }
@@ -175,8 +188,8 @@ sub B::OP::lint {}
 
 sub B::COP::lint {
     my $op = shift;
-    if ($op->ppaddr eq "pp_nextstate") {
-	$file = $op->filegv->SV->PV;
+    if ($op->name eq "nextstate") {
+	$file = $op->file;
 	$line = $op->line;
 	$curstash = $op->stash->NAME;
     }
@@ -184,24 +197,24 @@ sub B::COP::lint {
 
 sub B::UNOP::lint {
     my $op = shift;
-    my $ppaddr = $op->ppaddr;
-    if ($check{context} && ($ppaddr eq "pp_rv2av" || $ppaddr eq "pp_rv2hv")) {
+    my $opname = $op->name;
+    if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
 	my $parent = parents->[0];
-	my $pname = $parent->ppaddr;
+	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 "pp_null") {
-	    my $gpname = parents->[1]->ppaddr;
-	    return if $gpname eq "pp_enteriter" || $gpname eq "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",
-		$ppaddr eq "pp_rv2av" ? "array" : "hash", $parent->desc);
+		$opname eq "rv2av" ? "array" : "hash", $parent->desc);
     }
-    if ($check{private_names} && $ppaddr eq "pp_method") {
+    if ($check{private_names} && $opname eq "method") {
 	my $methop = $op->first;
-	if ($methop->ppaddr eq "pp_const") {
+	if ($methop->name eq "const") {
 	    my $method = $methop->sv->PV;
 	    if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
 		warning("Illegal reference to private method name $method");
@@ -213,14 +226,12 @@ sub B::UNOP::lint {
 sub B::PMOP::lint {
     my $op = shift;
     if ($check{implicit_read}) {
-	my $ppaddr = $op->ppaddr;
-	if ($ppaddr eq "pp_match" && !($op->flags & OPf_STACKED)) {
+	if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
 	    warning('Implicit match on $_');
 	}
     }
     if ($check{implicit_write}) {
-	my $ppaddr = $op->ppaddr;
-	if ($ppaddr eq "pp_subst" && !($op->flags & OPf_STACKED)) {
+	if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
 	    warning('Implicit substitution on $_');
 	}
     }
@@ -229,34 +240,48 @@ sub B::PMOP::lint {
 sub B::LOOP::lint {
     my $op = shift;
     if ($check{implicit_read} || $check{implicit_write}) {
-	my $ppaddr = $op->ppaddr;
-	if ($ppaddr eq "pp_enteriter") {
+	if ($op->name eq "enteriter") {
 	    my $last = $op->last;
-	    if ($last->ppaddr eq "pp_gv" && $last->gv->NAME eq "_") {
+	    if ($last->name eq "gv" && $last->gv->NAME eq "_") {
 		warning('Implicit use of $_ in foreach');
 	    }
 	}
     }
 }
 
-sub B::GVOP::lint {
+sub B::SVOP::lint {
     my $op = shift;
-    if ($check{dollar_underscore} && $op->ppaddr eq "pp_gvsv"
+    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 $ppaddr = $op->ppaddr;
-	my $gv = $op->gv;
-	if (($ppaddr eq "pp_gv" || $ppaddr eq "pp_gvsv")
-	    && $gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash)
-	{
-	    warning('Illegal reference to private name %s', $gv->NAME);
+	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->ppaddr eq "pp_gv" && $op->next->ppaddr eq "pp_entersub") {
+	if ($op->name eq "gv"
+	    && $op->next->name eq "entersub")
+	{
 	    my $gv = $op->gv;
 	    my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
 	    no strict 'refs';
@@ -266,7 +291,7 @@ sub B::GVOP::lint {
 	    }
 	}
     }
-    if ($check{regexp_variables} && $op->ppaddr eq "pp_gvsv") {
+    if ($check{regexp_variables} && $op->name eq "gvsv") {
 	my $name = $op->gv->NAME;
 	if ($name =~ /^[&'`]$/) {
 	    warning('Use of regexp variable $%s', $name);
@@ -291,11 +316,11 @@ sub do_lint {
     
     # 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 =~ /::$/;
+    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
@@ -350,7 +375,7 @@ sub compile {
 	    %check = ();
 	}
 	else {
-	    if ($opt =~ s/^no-//) {
+	    if ($opt =~ s/^no_//) {
 		$check{$opt} = 0;
 	    }
 	    else {