Re^2: Different result for 'foreach' vs 'while shift' arrayref (Perl::Critic::Policy::ControlStructures::ProhibitShiftLoopCondition)

[Anonymous Monk]

The module site\lib\Perl\Critic\Policy\ControlStructures\ProhibitShiftLoopCondition.pm

package Perl::Critic::Policy::ControlStructures::ProhibitShiftLoopCond
+ition;
use strict;
use warnings;
use PPIx::XPath;
use Tree::XPathEngine;

sub PPI::Structure::For::initialization {
    ( grep { $_->isa( 'PPI::Statement' ) } $_[0]->children )[0];
}

sub PPI::Structure::For::condition {
    ( grep { $_->isa( 'PPI::Statement' ) } $_[0]->children )[1];
}

sub PPI::Structure::For::afterthought {
    ( grep { $_->isa( 'PPI::Statement' ) } $_[0]->children )[2];
}
sub PPI::Token::xf { goto &PPI::Node::xf }

sub PPI::Node::xf {
    my( $node, $query ) = @_;
    $query = PPIx::XPath->clean_xpath_expr( $query );
    $::pxp ||= Tree::XPathEngine->new();
    return $::pxp->findnodes( $query, $node );
}

use Readonly;

use Perl::Critic::Utils qw{ :severities };
use base 'Perl::Critic::Policy';

our $VERSION = '0.01';

Readonly::Scalar my $DESC =>
q{don't write while(my $foo = shift @bar){...} instead write while(@ba
+r){my $foo = shift@bar;...} };
Readonly::Scalar my $EXPL =>
q{@bar can contain undef and shift returns undef when @bar empty};

sub supported_parameters { return() }
sub default_severity     { return $SEVERITY_MEDIUM }
sub default_themes       { return qw< bugs maintenance > }
sub applies_to           { return qw/PPI::Document/ }

sub violates {
    my( $policy, $doc, $criticdoc ) = @_;
    my @violas;
    for my $node (
        $doc->xf(
            q{
  //Statement-Compound[ @type = 'for' or @type = 'foreach' or @type = 
+'while'   ] 
| //Statement[  ./Token-Word[.='do'] ]
                              }
        )
      )
    {
        push @violas, _violas( $policy, $node, undef );
    }
    return @violas;
} ## end sub violates

sub _violas {
    my( $self, $elem, undef ) = @_;
    my @violas;
    for my $for ( $elem->xf( q{    .//Structure-For    } ) ) {
        my $condition = $for->condition;
        my( $evil ) = $condition->xf(
            q{
    .//Token-Word[ . = 'shift' or . = 'pop' ]
    }
        );
        if( $evil ) {
            push @violas, $self->violation( $DESC, $EXPL, $condition )
+;
        }
    }

#~ "while"   /Statement-Compound[1]/Token-Word[1]
#~ "="       /Statement-Compound[1]/Structure-Condition[1]/Statement-V
+ariable[1]/Token-Operator[1]
#~ "shift"   /Statement-Compound[1]/Structure-Condition[1]/Statement-V
+ariable[1]/Token-Word[2]
#~ "\$array" /Statement-Compound[1]/Structure-Condition[1]/Statement-V
+ariable[1]/Token-Symbol[2]

    for my $while_shift_array (
        $elem->xf(
            q{
./Token-Word[ . = 'while' ]
/following-sibling::Structure-Condition
/Statement-Variable
//Token-Word[ . = 'shift' or . = 'pop' ]

                                           }
        )
      )
    {
        for my $var (
            $while_shift_array->xf(
                q{
./following-sibling::Token-Symbol[ @raw_type = '$' or @raw_type = '@' 
+]
| ./following-sibling::Token-Cast[ . = '@' ]
        }
            )
          )
        {
            push @violas, $self->violation( $DESC, $EXPL, $while_shift
+_array );
            last;
        }
    }
    return @violas;
} ## end sub _violas
1;
1;
__END__

=pod

=head1 NAME

Perl::Critic::Policy::ControlStructures::ProhibitShiftLoopCondition - 
+don't write while(my $foo = shift @bar){...} instead write while(@bar
+){my $foo = shift@bar;...} 

=head1 DESCRIPTION

don't write

    while( my $foo = shift @bar ){
        ...
    }

instead write

    while( @bar ){
        my $foo = shift @bar;
        ...
    }


=head1 VERSION

Version 0.01


=head1 EVERYTHING ELSE

license, terms and EVERYTHING ELSE, same as Perl/Perl::Critic...

=cut

the "test" file

## count of violations 11 below
while( my $foo = shift @$array ){ ... }
while( my $foo = shift $array ){ ... }
while( my $foo = shift @array ){ ... }
for(; my $bad = shift @$array ){ ... }
for(; my $bad = shift $array ){ ... }
for(; my $bad = shift @array ){ ... }
for(; my $foo = shift @array; ){ ... }
foreach( my $notnull=9; my $foo = shift @array;  $notnull++ ){ ... }
foreach( my $notnull=9; my $foo = shift @array;  ){ ... }

while
##
(
##
my $foo = shift @$array ){ ... }

do { print "$foo\n"; }
while ## blah
( my $foo = shift @array )
## blah
;
## count of violations 11 above

## no flags thrown, none, 5 of none
for( ; ; ){ ... }
for(;;){ ... }
for(;;shift @array){ print "@array\n"; }
for( (my @mon = 1..3),(my @day= 8..10); @mon || @day; shift @mon, pop 
+@day){ for my $mon (@mon){ printf q{ %2s %2s |}, $mon,$_ for @day; } 
+print "\n" }
for(my @months = 1..10; @months; shift @months ){ print "@months\n$mon
+ths[0]\n\n"; }