From: Joshua ben Jore <jjore@cpan.org>
Date: Wed, 5 Apr 2006 01:11:11 +0000 (-0500)
Subject: Re: expr foreach (...) isn't a B::Lint warning anymore
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2e9e4ed729874a5a74677836e909498426ee1e3e;p=p5sagit%2Fp5-mst-13.2.git

Re: expr foreach (...) isn't a B::Lint warning anymore
From: "Joshua ben Jore" <twists@gmail.com>
Message-ID: <dc5c751d0604042311v354547aanf482b3259e56ebb8@mail.gmail.com>

p4raw-id: //depot/perl@27727
---

diff --git a/ext/B/B/Lint.pm b/ext/B/B/Lint.pm
index 05110bf..ebd0a7a 100644
--- a/ext/B/B/Lint.pm
+++ b/ext/B/B/Lint.pm
@@ -1,6 +1,6 @@
 package B::Lint;
 
-our $VERSION = '1.05';
+our $VERSION = '1.06';
 
 =head1 NAME
 
@@ -163,7 +163,8 @@ Malcolm Beattie, mbeattie@sable.ox.ac.uk.
 use strict;
 use B qw(walkoptree_slow main_root walksymtable svref_2object parents
          class
-         OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
+         OPpOUR_INTRO
+         OPf_WANT_VOID OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
         );
 
 my $file = "unknown";		# shadows current filename
@@ -252,13 +253,20 @@ sub B::UNOP::lint {
 	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}"
+	# Three special cases to deal with: "foreach (@foo)", "delete $a{$b}", and "exists $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
+	# a grandparent of pp_enteriter, pp_delete, pp_exists
 	if ($pname eq "null") {
 	    my $gpname = parents->[1]->name;
-	    return if $gpname eq "enteriter" || $gpname eq "delete";
+	    return if $gpname eq "enteriter"
+                   or $gpname eq "delete"
+                   or $gpname eq "exists";
 	}
+	
+	# our( @bar );
+	return if $op->private & OPpOUR_INTRO
+                  and ( $op->flags & OPf_WANT ) == OPf_WANT_VOID;
+	
 	warning("Implicit scalar context for %s in %s",
 		$opname eq "rv2av" ? "array" : "hash", $parent->desc);
     }
@@ -305,7 +313,10 @@ sub B::LOOP::lint {
     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 "_") {
+	    my $body = $op->redoop;
+	    if ( $last->name eq "gv"
+		 and $last->gv->NAME eq "_"
+	         and $body->name =~ /\A(?:next|db|set)state\z/ ) {
 		warning('Implicit use of $_ in foreach');
 	    }
 	}
@@ -316,6 +327,17 @@ sub B::LOOP::lint {
     return;
 }
 
+sub _inside_foreach_statement {
+    for my $op ( @{ parents() || [] } ) {
+	$op->name eq 'leaveloop' or next;
+	my $first = $op->first;
+	$first->name eq 'enteriter' or next;
+	$first->redoop->name !~ /\A(?:next|db|set)state\z/ or next;
+	return 1;
+    }
+    return 0;
+}
+
 sub B::SVOP::lint {
     my $op = shift;
     if ( $check{bare_subs} && $op->name eq 'const'
@@ -326,8 +348,14 @@ sub B::SVOP::lint {
 	    warning "Bare sub name '" . $sv->PV . "' interpreted as string";
 	}
     }
-    if ($check{dollar_underscore} && $op->name eq "gvsv"
-	&& $op->gv->NAME eq "_")
+    if ($check{dollar_underscore}
+	and $op->name eq "gvsv"
+	and $op->gv->NAME eq "_"
+	and not ( _inside_foreach_statement()
+		  or do { my $ctx = join( ' ',
+					  map $_->name,
+					  @{ parents() || [] } );
+			  $ctx =~ /(grep|map)start \1while/ } ) )
     {
 	warning('Use of $_');
     }
diff --git a/ext/B/t/lint.t b/ext/B/t/lint.t
index 01bee1b..974e598 100644
--- a/ext/B/t/lint.t
+++ b/ext/B/t/lint.t
@@ -16,7 +16,7 @@ BEGIN {
     require 'test.pl';
 }
 
-plan tests => 18; # adjust also number of skipped tests !
+plan tests => 24; # adjust also number of skipped tests !
 
 # Runs a separate perl interpreter with the appropriate lint options
 # turned on
@@ -39,6 +39,10 @@ runlint 'context', '$foo = length @bar', <<'RESULT';
 Implicit scalar context for array in length at -e line 1
 RESULT
 
+runlint 'context', 'our @bar', '';
+
+runlint 'context', 'exists $BAR{BAZ}', '';
+
 runlint 'implicit-read', '/foo/', <<'RESULT';
 Implicit match on $_ at -e line 1
 RESULT
@@ -66,14 +70,20 @@ SKIP : {
     skip("Doesn't work with threaded perls",11)
        if $Config{useithreads} || ($] < 5.009 && $Config{use5005threads});
 
-    runlint 'implicit-read', '1 for @ARGV', <<'RESULT', 'implicit-read in foreach';
+    runlint 'implicit-read', 'for ( @ARGV ) { 1 }', <<'RESULT', 'implicit-read in foreach';
 Implicit use of $_ in foreach at -e line 1
 RESULT
 
+    runlint 'implicit-read', '1 for @ARGV', '', 'implicit-read in foreach';
+
     runlint 'dollar-underscore', '$_ = 1', <<'RESULT';
 Use of $_ at -e line 1
 RESULT
 
+    runlint 'dollar-underscore', 'foo( $_ ) for @A', '';
+    runlint 'dollar-underscore', 'map { foo( $_ ) } @A', '';
+    runlint 'dollar-underscore', 'grep { foo( $_ ) } @A', '';
+
     runlint 'dollar-underscore', 'print', <<'RESULT', 'dollar-underscore in print';
 Use of $_ at -e line 1
 RESULT