Modified source files and compiled any and armel versions of packages

[pkg-perl] / deb-src / libperl-critic-perl / libperl-critic-perl-1.088 / lib / Perl / Critic / Policy / ErrorHandling / RequireCheckingReturnValueOfEval.pm

##############################################################################
#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm $
#     $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
#   $Author: clonezone $
# $Revision: 2489 $
##############################################################################

package Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval;

use 5.006001;
use strict;
use warnings;

use Readonly;

use Scalar::Util qw< refaddr >;

use Perl::Critic::Utils qw< :booleans :characters :severities hashify >;
use base 'Perl::Critic::Policy';

our $VERSION = '1.088';

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

Readonly::Scalar my $DESC => 'Return value of eval not tested.';
## no critic (RequireInterpolationOfMetachars)
Readonly::Scalar my $EXPL =>
    q<You can't depend upon the value of $@/$EVAL_ERROR to tell whether an eval failed.>;
## use critic

Readonly::Hash my %BOOLEAN_OPERATORS => hashify qw< || && // or and >;
Readonly::Hash my %POSTFIX_OPERATORS =>
    hashify qw< for foreach if unless while until >;

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

sub supported_parameters { return ()                 }
sub default_severity     { return $SEVERITY_MEDIUM   }
sub default_themes       { return qw( core bugs )    }
sub applies_to           { return 'PPI::Token::Word' }

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

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

    return if $elem->content() ne 'eval';

    my $evaluated = $elem->snext_sibling() or return; # Nothing to eval!
    my $following = $evaluated->snext_sibling();

    return if _is_in_right_hand_side_of_assignment($elem);
    return if _is_in_postfix_expression($elem);
    return if
        _is_in_correct_position_in_a_condition_or_foreach_loop_collection(
            $elem,
            $following,
        );

    if (
            $following
        and $following->isa('PPI::Token::Operator')
        and $BOOLEAN_OPERATORS{ $following->content() }
    ) {
        return;
    }

    return $self->violation($DESC, $EXPL, $elem);
}

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

sub _is_in_right_hand_side_of_assignment {
    my ($elem) = @_;

    my $previous = $elem->sprevious_sibling();

    if (not $previous) {
        $previous =
            _grandparent_for_is_in_right_hand_side_of_assignment($elem);
    }

    while ($previous) {
        my $base_previous = $previous;

        EQUALS_SCAN:
        while ($previous) {
            if ( $previous->isa('PPI::Token::Operator') ) {
                return $TRUE if $previous->content() eq q<=>;
                last EQUALS_SCAN if _is_effectively_a_comma($previous);
            }
            $previous = $previous->sprevious_sibling();
        }

        $previous =
            _grandparent_for_is_in_right_hand_side_of_assignment($base_previous);
    }

    return;
}

sub _grandparent_for_is_in_right_hand_side_of_assignment {
    my ($elem) = @_;

    my $parent = $elem->parent() or return;
    $parent->isa('PPI::Statement') or return;

    my $grandparent = $parent->parent() or return;

    if (
            $grandparent->isa('PPI::Structure::Constructor')
        or  $grandparent->isa('PPI::Structure::List')
    ) {
        return $grandparent;
    }

    return;
}

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

Readonly::Scalar my $CONDITION_POSITION_IN_C_STYLE_FOR_LOOP => 1;

sub _is_in_correct_position_in_a_condition_or_foreach_loop_collection {
    my ($elem, $following) = @_;

    my $parent = $elem->parent();
    while ($parent) {
        if ( $parent->isa('PPI::Structure::Condition') ) {
            return
                _is_in_correct_position_in_a_structure_condition(
                    $elem, $parent, $following,
                );
        }

        if ( $parent->isa('PPI::Structure::ForLoop') ) {
            my @for_loop_components = $parent->schildren();

            return $TRUE if 1 == @for_loop_components;
            my $condition =
                $for_loop_components[$CONDITION_POSITION_IN_C_STYLE_FOR_LOOP]
                or return;

            return _descendant_of($elem, $condition);
        }

        $parent = $parent->parent();
    }

    return;
}

sub _is_in_correct_position_in_a_structure_condition {
    my ($elem, $parent, $following) = @_;

    my $level = $elem;
    while ($level and refaddr $level != $parent) {
        my $cursor = refaddr $elem == refaddr $level ? $following : $level;

        IS_FINAL_EXPRESSION_AT_DEPTH:
        while ($cursor) {
            if ( _is_effectively_a_comma($cursor) ) {
                $cursor = $cursor->snext_sibling();
                while ( _is_effectively_a_comma($cursor) ) {
                    $cursor = $cursor->snext_sibling();
                }

                # Semicolon would be a syntax error here.
                return if $cursor;
                last IS_FINAL_EXPRESSION_AT_DEPTH;
            }

            $cursor = $cursor->snext_sibling();
        }

        my $statement = $level->parent();
        return $TRUE if not $statement; # Shouldn't happen.
        return $TRUE if not $statement->isa('PPI::Statement'); # Shouldn't happen.

        $level = $statement->parent();
        if (
                not $level
            or  (
                    not $level->isa('PPI::Structure::List')
                and not $level->isa('PPI::Structure::Condition')
            )
        ) {
            # Shouldn't happen.
            return $TRUE;
        }
    }

    return $TRUE;
}

# Replace with PPI implementation once it is released.
sub _descendant_of {
    my ($cursor, $potential_ancestor) = @_;

    return $EMPTY if not $potential_ancestor;

    while ( refaddr $cursor != refaddr $potential_ancestor ) {
        $cursor = $cursor->parent() or return $EMPTY;
    }

    return 1;
}

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

sub _is_in_postfix_expression {
    my ($elem) = @_;

    my $previous = $elem->sprevious_sibling();
    while ($previous) {
        if (
                $previous->isa('PPI::Token::Word')
            and $POSTFIX_OPERATORS{ $previous->content() }
        ) {
            return $TRUE
        }
        $previous = $previous->sprevious_sibling();
    }

    return;
}

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

sub _is_effectively_a_comma {
    my ($elem) = @_;

    return if not $elem;

    return
            $elem->isa('PPI::Token::Operator')
        &&  (
                $elem->content() eq $COMMA
            ||  $elem->content() eq $FATCOMMA
        );
}

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

1;

__END__

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

=pod

=for stopwords destructors

=head1 NAME

Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval - You can't depend upon the value of C<$@>/C<$EVAL_ERROR> to tell whether an C<eval> failed.

=head1 AFFILIATION

This Policy is part of the core L<Perl::Critic> distribution.


=head1 DESCRIPTION

A common idiom in perl for dealing with possible errors is to use
C<eval> followed by a check of C<$@>/C<$EVAL_ERROR>:

    eval {
        ...
    };
    if ($EVAL_ERROR) {
        ...
    }

There's a problem with this: the value of C<$EVAL_ERROR> can change
between the end of the C<eval> and the C<if> statement.  The issue is
object destructors:

    package Foo;

    ...

    sub DESTROY {
        ...
        eval { ... };
        ...
    }

    package main;

    eval {
        my $foo = Foo->new();
        ...
    };
    if ($EVAL_ERROR) {
        ...
    }

Assuming there are no other references to C<$foo> created, when the
C<eval> block in C<main> is exited, C<Foo::DESTROY()> will be invoked,
regardless of whether the C<eval> finished normally or not.  If the
C<eval> in C<main> fails, but the C<eval> in C<Foo::DESTROY()>
succeeds, then C<$EVAL_ERROR> will be empty by the time that the C<if>
is executed.  Additional issues arise if you depend upon the exact
contents of C<$EVAL_ERROR> and both C<eval>s fail, because the
messages from both will be concatenated.

Even if there isn't an C<eval> directly in the C<DESTROY()> method
code, it may invoke code that does use C<eval> or otherwise affects
C<$EVAL_ERROR>.

The solution is to ensure that, upon normal exit, an C<eval> returns a
true value and to test that value:

    # Constructors are no problem.
    my $object = eval { Class->new() };

    # To cover the possiblity that an operation may correctly return a
    # false value, end the block with "1":
    if ( eval { something(); 1 } ) {
        ...
    }

    eval {
        ...
        1;
    }
        or do {
            # Error handling here
        };

Unfortunately, you can't use the C<defined> function to test the
result; C<eval> returns an empty string on failure.

"But we don't use DESTROY() anywhere in our code!" you say.  That may
be the case, but do any of the third-party modules you use have them?
What about any you may use in the future or updated versions of the
ones you already use?


=head1 CONFIGURATION

This Policy is not configurable except for the standard options.


=head1 SEE ALSO

See thread on perl5-porters starting here:
L<http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-06/msg00537.html>.


=head1 AUTHOR

Elliot Shank C<< <perl@galumph.com> >>

=head1 COPYRIGHT

Copyright (c) 2008 Elliot Shank.  All rights reserved.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  The full text of this license
can be found in the LICENSE file included with this module.

=cut

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 78
#   indent-tabs-mode: nil
#   c-indentation-style: bsd
# End:
# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :