view release on metacpan or  search on metacpan

share/PerlCritic/Critic/Policy/Variables/RequireNegativeIndices.pm  view on Meta::CPAN

sub default_severity     { return $SEVERITY_HIGH              }
sub default_themes       { return qw( core maintenance pbp )  }
sub applies_to           { return 'PPI::Structure::Subscript' }

#-----------------------------------------------------------------------------

sub violates {
    my ( $self, $elem, $doc ) = @_;

    return if $elem->braces ne '[]';
    my ($name, $isref) = _is_bad_index( $elem );
    return if ( !$name );
    return if !_is_array_name( $elem, $name, $isref );
    return $self->violation( $DESC, $EXPL, $elem );
}

Readonly::Scalar my $MAX_EXPRESSION_COMPLEXETY => 4;

sub _is_bad_index {
    # return (varname, 0|1) if this could be a violation
    my ( $elem ) = @_;

    my @children = $elem->schildren();
    return if @children != 1; # too complex
    return if !$children[0]->isa( 'PPI::Statement::Expression'); # too complex

    # This is the expression elements that compose the array indexing
    my @expr = $children[0]->schildren();
    return if !@expr || @expr > $MAX_EXPRESSION_COMPLEXETY;
    my ($name, $isref, $isindex) = _is_bad_var_in_index(\@expr);
    return if !$name;
    return $name, $isref if !@expr && $isindex;
    return if !_is_minus_number(@expr);
    return $name, $isref;
}

sub _is_bad_var_in_index {
    # return (varname, isref=0|1, isindex=0|1) if this could be a violation
    my ( $expr ) = @_;

    if ( $expr->[0]->isa('PPI::Token::ArrayIndex') ) {
        # [$#arr]
        return _arrayindex($expr);
    }
    elsif ( $expr->[0]->isa('PPI::Token::Cast') ) {
        # [$#{$arr} ...] or [$#$arr ...] or [@{$arr} ...] or [@$arr ...]
        return _cast($expr);
    }
    elsif ($expr->[0]->isa('PPI::Token::Symbol')) {
        # [@arr ...]
        return _symbol($expr);
    }

    return;
}

sub _arrayindex {
    # return (varname, isref=0|1, isindex=0|1) if this could be a violation
    my ( $expr ) = @_;
    my $arrindex = shift @{$expr};
    if ($arrindex->content =~ m/\A \$[#] (.*) \z /xms) { # What else could it be???
       return $1, 0, 1;
    }
    return;
}

sub _cast {
    # return (varname, isref=0|1, isindex=0|1) if this could be a violation
    my ( $expr ) = @_;
    my $cast = shift @{$expr};
    if ( $cast eq q{$#} || $cast eq q{@} ) { ## no critic(RequireInterpolationOfMetachars)
        my $isindex = $cast eq q{$#} ? 1 : 0;  ## no critic(RequireInterpolationOfMetachars)
        my $arrvar = shift @{$expr};
        if ($arrvar->isa('PPI::Structure::Block')) {
            # look for [$#{$arr} ...] or [@{$arr} ...]
            my @blockchildren = $arrvar->schildren();
            return if @blockchildren != 1;
            return if !$blockchildren[0]->isa('PPI::Statement');
            my @ggg = $blockchildren[0]->schildren;
            return if @ggg != 1;
            return if !$ggg[0]->isa('PPI::Token::Symbol');
            if ($ggg[0] =~ m/\A \$ (.*) \z/xms) {
                return $1, 1, $isindex;
            }
        }
        elsif ( $arrvar->isa('PPI::Token::Symbol') ) {
           # look for [$#$arr ...] or [@$arr ...]
           if ($arrvar =~ m/\A \$ (.*) \z/xms) {
              return $1, 1, $isindex;
           }
        }
    }
    return;
}

sub _symbol {
    # return (varname, isref=0|1, isindex=0|1) if this could be a violation
    my ( $expr ) = @_;
    my $arrvar = shift @{$expr};
    if ($arrvar =~ m/\A \@ (.*) \z/xms) {
       return $1, 0, 0;
    }
    return;
}

sub _is_minus_number {  # return true if @expr looks like "- n"
    my @expr = @_;

    return if !@expr;

    return if @expr != 2;

    my $op = shift @expr;
    return if !$op->isa('PPI::Token::Operator');
    return if $op ne q{-};

    my $number = shift @expr;
    return if !$number->isa('PPI::Token::Number');

    return 1;
}