File Coverage

blib/lib/Perl/Critic/Policy/TryTiny/ProhibitExitingSubroutine.pm

Criterion	Covered	Total	%
statement	53	57	92.9
branch	22	30	73.3
condition	13	24	54.1
subroutine	12	13	92.3
pod	4	5	80.0
total	104	129	80.6

use strict;
use warnings;
use utf8;

package Perl::Critic::Policy::TryTiny::ProhibitExitingSubroutine;
# ABSTRACT: Ban next/last/return in Try::Tiny blocks
$Perl::Critic::Policy::TryTiny::ProhibitExitingSubroutine::VERSION = '0.001';
use Readonly;
use Perl::Critic::Utils qw( :severities :classification :ppi );

use base 'Perl::Critic::Policy';

Readonly::Scalar my $DESC => "Using next/last/redo/return in a Try::Tiny block is ambiguous";
Readonly::Scalar my $EXPL => "Using next/last/redo without a label or using return in a Try::Tiny block is ambiguous, did you intend to exit out of the try/catch/finally block or the surrounding block?";

sub supported_parameters {
    return ();
}

sub default_severity {
    return $SEVERITY_HIGH;
}

sub default_themes {
    return qw(bugs);
}

sub applies_to {
    return 'PPI::Token::Word';
}

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

    return if $elem->content ne 'try';
    return if ! is_function_call($elem);

    my @blocks_to_check;

    if (my $try_block = $elem->snext_sibling()) {
        if ($try_block->isa('PPI::Structure::Block')) {
            push @blocks_to_check, $try_block;
        }
        my $sib = $try_block->snext_sibling();
        if ($sib and $sib->content eq 'catch' and my $catch_block = $sib->snext_sibling()) {
            if ($catch_block->isa('PPI::Structure::Block')) {
                push @blocks_to_check, $catch_block;
            }
            $sib = $catch_block->snext_sibling();
        }
        if ($sib and $sib->content eq 'finally' and my $finally_block = $sib->snext_sibling()) {
            if (finally_block->isa('PPI::Structure::Block')) {
                push @blocks_to_check, $finally_block;
            }
        }
    }

    for my $block_to_check (@blocks_to_check) {
        my $violation = $self->_check_block($block_to_check);
        if (defined($violation)) {
            return $violation;
        }
    }
    return;
}

sub _check_block {
    my $self = shift;
    my $block = shift;

    for my $word (@{ $block->find('PPI::Token::Word') || [] }) {
        if ($word eq 'return') {
            return $self->violation($DESC, $EXPL, $word);
        }

        my $sib = $word->snext_sibling;

        if ($word eq 'next' || $word eq 'redo' || $word eq 'last') {
            if (! $sib || ! _is_label($sib)) {
                return $self->violation($DESC, $EXPL, $word);
            }
        }
    }
    return;
}

sub _is_label {
    my $element = shift;

    if ($element eq 'if' || $element eq 'unless') {
        return 0;
    }

    return $element =~ /^[_a-z]+$/i ? 1 : 0;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Perl::Critic::Policy::TryTiny::ProhibitExitingSubroutine - Ban next/last/return in Try::Tiny blocks

=head1 VERSION

version 0.001

=head1 DESCRIPTION

Take this code:

    use Try::Tiny;

    for my $item (@array) {
        try {
            next if $item == 2;
            # other code
        }
        catch {
            warn $_;
        };
        # other code
    }

The next statement will not go the the next iteration of the for-loop, rather,
it will exit the "try" block, emitting a warning if warnings are enabled.

This is probably not what the developer had intended, so this policy prohibits it.

One way to fix this is to use labels:

    use Try::Tiny;

    ITEM:
    for my $item (@array) {
        try {
            if ($item == 2) {
                no warnings 'exiting';
                next ITEM;
            }
            # other code
        }
        catch {
            warn $_;
        };
        # other code
    }

=head1 CONFIGURATION

This Policy is not configurable except for the standard options.

=head1 KNOWN BUGS

This policy assumes that L<Try::Tiny> is being used, and doesn't check for
whether an alternative like L<TryCatch>.

=head1 AUTHOR

David D Lowe <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014 by Lokku <[e-mail]>.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut