Perl::Critic::Policy::ErrorHandling::RequireCarping - Use functions from L<Carp|Carp> instead of C<warn> or C<die>.

Perl-Critic documentation Contained in the Perl-Critic distribution.

Index

Code Index:

NAME

Top

Perl::Critic::Policy::ErrorHandling::RequireCarping - Use functions from Carp (Carp) instead of warn or die.

AFFILIATION

Top

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

DESCRIPTION

Top

The die and warn functions both report the file and line number where the exception occurred. But if someone else is using your subroutine, they usually don't care where your code blew up. Instead, they want to know where their code invoked the subroutine. The Carp (Carp) module provides alternative methods that report the exception from the caller's file and line number.

By default, this policy will not complain about die or warn, if it can determine that the message will always result in a terminal newline. Since perl suppresses file names and line numbers in this situation, it is assumed that no stack traces are desired either and none of the Carp (Carp) functions are necessary.

    die "oops" if $explosion;             #not ok
    warn "Where? Where?!" if $tiger;      #not ok

    open my $mouth, '<', 'food'
        or die 'of starvation';           #not ok

    if (! $dentist_appointment) {
        warn "You have bad breath!\n";    #ok
    }

    die "$clock not set.\n" if $no_time;  #ok

    my $message = "$clock not set.\n";
    die $message if $no_time;             #not ok, not obvious

CONFIGURATION

Top

By default, this policy allows uses of die and warn ending in an explicit newline. If you give this policy an allow_messages_ending_with_newlines option in your .perlcriticrc with a false value, then this policy will prohibit such uses.

    [ErrorHandling::RequireCarping]
    allow_messages_ending_with_newlines = 0

If you give this policy an allow_in_main_unless_in_subroutine option in your .perlcriticrc with a true value, then this policy will allow die and warn in name space main:: unless they appear in a subroutine, even if they do not end in an explicit newline.

    [ErrorHandling::RequireCarping]
    allow_in_main_unless_in_subroutine = 1

BUGS

Top

Should allow die when it is obvious that the "message" is a reference.

SEE ALSO

Top

Carp::Always

AUTHOR

Top

Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>

COPYRIGHT

Top

Copyright (c) 2005-2011 Imaginative Software Systems. 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.

Perl-Critic documentation Contained in the Perl-Critic distribution. 
##############################################################################
#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm $
#     $Date: 2011-05-15 16:34:46 -0500 (Sun, 15 May 2011) $
#   $Author: clonezone $
# $Revision: 4078 $
##############################################################################

package Perl::Critic::Policy::ErrorHandling::RequireCarping;

use 5.006001;
use strict;
use warnings;
use Readonly;

use Perl::Critic::Utils qw{
    :booleans :characters :severities :classification :data_conversion
};
use Perl::Critic::Utils::PPI qw{ is_ppi_expression_or_generic_statement };
use base 'Perl::Critic::Policy';

our $VERSION = '1.116';

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

Readonly::Scalar my $EXPL => [ 283 ];

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

sub supported_parameters {
    return (
        {
            name           => 'allow_messages_ending_with_newlines',
            description    => q{Don't complain about die or warn if the message ends in a newline.},
            default_string => '1',
            behavior       => 'boolean',
        },
        {
            name           => 'allow_in_main_unless_in_subroutine',
            description    => q{Don't complain about die or warn in main::, unless in a subroutine.},
            default_string => '0',
            behavior       => 'boolean',
        },
    );
}

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

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

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

    my $alternative;
    if ( $elem eq 'warn' ) {
        $alternative = 'carp';
    }
    elsif ( $elem eq 'die' ) {
        $alternative = 'croak';
    }
    else {
        return;
    }

    return if ! is_function_call($elem);

    if ($self->{_allow_messages_ending_with_newlines}) {
        return if _last_flattened_argument_list_element_ends_in_newline($elem);
    }

    return if $self->{_allow_in_main_unless_in_subroutine}
        && !$self->_is_element_contained_in_subroutine( $elem )
        && $self->_is_element_in_namespace_main( $elem );    # RT #56619

    my $desc = qq{"$elem" used instead of "$alternative"};
    return $self->violation( $desc, $EXPL, $elem );
}

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

sub _last_flattened_argument_list_element_ends_in_newline {
    my $die_or_warn = shift;

    my $last_flattened_argument =
        _find_last_flattened_argument_list_element($die_or_warn)
        or return $FALSE;

    if ( $last_flattened_argument->isa('PPI::Token::Quote') ) {
        my $last_flattened_argument_string =
            $last_flattened_argument->string();
        if (
                $last_flattened_argument_string =~ m{ \n \z }xms
            or (
                    (
                            $last_flattened_argument->isa('PPI::Token::Quote::Double')
                        or $last_flattened_argument->isa('PPI::Token::Quote::Interpolate')
                    )
                and $last_flattened_argument_string =~ m{ [\\] n \z }xms
            )
        ) {
            return $TRUE;
        }
    }
    elsif ( $last_flattened_argument->isa('PPI::Token::HereDoc') ) {
        return $TRUE;
    }

    return $FALSE
}

#-----------------------------------------------------------------------------
# Here starts the fun.  Explanation by example:
#
# Let's say we've got the following (contrived) statement:
#
#    die q{Isn't }, ( $this, ( " fun?\n" ) , ) if "It isn't Monday.";
#
# This statement should pass because the last parameter that die is going to
# get is C<" fun?\n">.
#
# The approach is to first find the last non-flattened parameter.  If this
# is a simple token, we're done.  Else, it's some aggregate thing.  We can't
# tell what C<some_function( "foo\n" )> is going to do, so we give up on
# anything other than a PPI::Structure::List.
#
# There are three possible scenarios for the children of a List:
#
#   * No children of the List, i.e. the list looks like C< ( ) >.
#   * One PPI::Statement::Expression element.
#   * One PPI::Statement element.  That's right, an instance of the base
#     statement class and not some subclass.  *sigh*
#
# In the first case, we're done.  The latter two cases get treated
# identically.  We get the last child of the Statement and start the search
# all over again.
#
# Back to our example.  The PPI tree for this expression is
#
#     PPI::Document
#       PPI::Statement
#         PPI::Token::Word    'die'
#         PPI::Token::Quote::Literal          'q{Isn't }'
#         PPI::Token::Operator        ','
#         PPI::Structure::List        ( ... )
#           PPI::Statement::Expression
#             PPI::Token::Symbol      '$this'
#             PPI::Token::Operator    ','
#             PPI::Structure::List    ( ... )
#               PPI::Statement::Expression
#                 PPI::Token::Quote::Double   '" fun?\n"'
#             PPI::Token::Operator    ','
#         PPI::Token::Word    'if'
#         PPI::Token::Quote::Double   '"It isn't Monday.\n"'
#         PPI::Token::Structure       ';'
#
# We're starting with the Word containing 'die' (it could just as well be
# 'warn') because the earlier parts of validate() have taken care of any
# other possibility.  We're going to scan forward through 'die's siblings
# until we reach what we think the end of its parameters are. So we get
#
#     1. A Literal. A perfectly good argument.
#     2. A comma operator. Looks like we've got more to go.
#     3. A List. Another argument.
#     4. The Word 'if'.  Oops.  That's a postfix operator.
#
# Thus, the last parameter is the List.  So, we've got to scan backwards
# through the components of the List; again, the goal is to find the last
# value in the flattened list.
#
# Before decending into the List, we check that it isn't a subroutine call by
# looking at its prior sibling.  In this case, the prior sibling is a comma
# operator, so it's fine.
#
# The List has one Expression element as we expect.  We grab the Expression's
# last child and start all over again.
#
#     1. The last child is a comma operator, which Perl will ignore, so we
#        skip it.
#     2. The comma's prior sibling is a List.  This is the last significant
#        part of the outer list.
#     3. The List's prior sibling isn't a Word, so we can continue because the
#        List is not a parameter list.
#     4. We go through the child Expression and find that the last child of
#        that is a PPI::Token::Quote::Double, which is a simple, non-compound
#        token.  We return that and we're done.

sub _find_last_flattened_argument_list_element {
    my $die_or_warn = shift;

    # Zoom forward...
    my $current_candidate =
        _find_last_element_in_subexpression($die_or_warn);

    # ... scan back.
    while (
            $current_candidate
        and not _is_simple_list_element_token( $current_candidate )
        and not _is_complex_expression_token( $current_candidate )
    ) {
        if ( $current_candidate->isa('PPI::Structure::List') ) {
            $current_candidate =
                _determine_if_list_is_a_plain_list_and_get_last_child(
                    $current_candidate,
                    $die_or_warn
                );
        } elsif ( not $current_candidate->isa('PPI::Token') ) {
            return;
        } else {
            $current_candidate = $current_candidate->sprevious_sibling();
        }
    }

    return if not $current_candidate;
    return if _is_complex_expression_token( $current_candidate );

    my $penultimate_element = $current_candidate->sprevious_sibling();
    if ($penultimate_element) {
        # Bail if we've got a Word in front of the Element that isn't
        # the original 'die' or 'warn' or anything else that isn't
        # a comma or dot operator.
        if ( $penultimate_element->isa('PPI::Token::Operator') ) {
            if (
                    $penultimate_element ne $COMMA
                and $penultimate_element ne $PERIOD
            ) {
                return;
            }
        } elsif ( $penultimate_element != $die_or_warn ) {
            return
        }
    }

    return $current_candidate;
}

#-----------------------------------------------------------------------------
# This is the part where we scan forward from the 'die' or 'warn' to find
# the last argument.

sub _find_last_element_in_subexpression {
    my $die_or_warn = shift;

    my $last_following_sibling;
    my $next_sibling = $die_or_warn;
    while (
            $next_sibling = $next_sibling->snext_sibling()
        and not _is_postfix_operator( $next_sibling )
    ) {
        $last_following_sibling = $next_sibling;
    }

    return $last_following_sibling;
}

#-----------------------------------------------------------------------------
# Ensure that the list isn't a parameter list.  Find the last element of it.

sub _determine_if_list_is_a_plain_list_and_get_last_child {
    my ($list, $die_or_warn) = @_;

    my $prior_sibling = $list->sprevious_sibling();

    if ( $prior_sibling ) {
        # Bail if we've got a Word in front of the List that isn't
        # the original 'die' or 'warn' or anything else that isn't
        # a comma operator.
        if ( $prior_sibling->isa('PPI::Token::Operator') ) {
            if ( $prior_sibling ne $COMMA ) {
                return;
            }
        } elsif ( $prior_sibling != $die_or_warn ) {
            return
        }
    }

    my @list_children = $list->schildren();

    # If zero children, nothing to look for.
    # If multiple children, then PPI is not giving us
    # anything we understand.
    return if scalar (@list_children) != 1;

    my $list_child = $list_children[0];

    # If the child isn't an Expression or it is some other subclass
    # of Statement, we again don't understand PPI's output.
    return if not is_ppi_expression_or_generic_statement($list_child);

    my @statement_children = $list_child->schildren();
    return if scalar (@statement_children) < 1;

    return $statement_children[-1];
}


#-----------------------------------------------------------------------------
Readonly::Hash my %POSTFIX_OPERATORS =>
    hashify qw{ if unless while until for foreach };

sub _is_postfix_operator {
    my $element = shift;

    if (
            $element->isa('PPI::Token::Word')
        and $POSTFIX_OPERATORS{$element}
    ) {
        return $TRUE;
    }

    return $FALSE;
}


Readonly::Array my @SIMPLE_LIST_ELEMENT_TOKEN_CLASSES =>
    qw{
        PPI::Token::Number
        PPI::Token::Word
        PPI::Token::DashedWord
        PPI::Token::Symbol
        PPI::Token::Quote
        PPI::Token::HereDoc
    };

sub _is_simple_list_element_token {
    my $element = shift;

    return $FALSE if not $element->isa('PPI::Token');

    foreach my $class (@SIMPLE_LIST_ELEMENT_TOKEN_CLASSES) {
        return $TRUE if $element->isa($class);
    }

    return $FALSE;
}


#-----------------------------------------------------------------------------
# Tokens that can't possibly be part of an expression simple
# enough for us to examine.

Readonly::Array my @COMPLEX_EXPRESSION_TOKEN_CLASSES =>
    qw{
        PPI::Token::ArrayIndex
        PPI::Token::QuoteLike
        PPI::Token::Regexp
        PPI::Token::Cast
        PPI::Token::Label
        PPI::Token::Separator
        PPI::Token::Data
        PPI::Token::End
        PPI::Token::Prototype
        PPI::Token::Attribute
        PPI::Token::Unknown
    };

sub _is_complex_expression_token {
    my $element = shift;

    return $FALSE if not $element->isa('PPI::Token');

    foreach my $class (@COMPLEX_EXPRESSION_TOKEN_CLASSES) {
        return $TRUE if $element->isa($class);
    }

    return $FALSE;
}

#-----------------------------------------------------------------------------
# Check whether the given element is contained in a subroutine.

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

    my $parent = $elem;
    while ( $parent = $parent->parent() ) {
        $parent->isa( 'PPI::Statement::Sub' ) and return $TRUE;
        $parent->isa( 'PPI::Structure::Block' ) or next;
        my $prior_elem = $parent->sprevious_sibling() or next;
        $prior_elem->isa( 'PPI::Token::Word' )
            and 'sub' eq $prior_elem->content()
            and return $TRUE;
    }

    return $FALSE;
}

#-----------------------------------------------------------------------------
# Check whether the given element is in main::

sub _is_element_in_namespace_main {
    my ( $self, $elem ) = @_;
    my $current_elem = $elem;
    my $prior_elem;

    while ( $current_elem ) {
        while ( $prior_elem = $current_elem->sprevious_sibling() ) {
            if ( $prior_elem->isa( 'PPI::Statement::Package' ) ) {
                return 'main' eq $prior_elem->namespace();
            }
        } continue {
            $current_elem = $prior_elem;
        }
        $current_elem = $current_elem->parent();
    }

    return $TRUE;
}

1;

__END__

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


# 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 :