#line 1
##############################################################################
#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm $
#     $Date: 2011-12-21 14:40:10 -0800 (Wed, 21 Dec 2011) $
#   $Author: thaljef $
# $Revision: 4106 $
##############################################################################

package Perl::Critic::Policy::InputOutput::RequireBriefOpen;

use 5.006001;
use strict;
use warnings;

use Readonly;

use List::MoreUtils qw(any);

use Perl::Critic::Utils qw{ :severities :classification :booleans
    hashify parse_arg_list
};
use base 'Perl::Critic::Policy';

our $VERSION = '1.117';

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

Readonly::Scalar my $DESC => q<Close filehandles as soon as possible after opening them..>;
Readonly::Scalar my $EXPL => [209];

Readonly::Scalar my $SCALAR_SIGIL => q<$>;
Readonly::Scalar my $GLOB_SIGIL   => q<*>;

# Identify the builtins that are equivalent to 'open' and 'close'. Note that
# 'return' is considered equivalent to 'close'.
Readonly::Hash my %CLOSE_BUILTIN => hashify( qw{
    close
    CORE::close
    CORE::GLOBAL::close
    return
} );
Readonly::Hash my %OPEN_BUILTIN => hashify( qw{
    open
    CORE::open
    CORE::GLOBAL::open
} );

# Possible values for $is_lexical
Readonly::Scalar my $NOT_LEXICAL => 0;  # Guaranteed only false value
Readonly::Scalar my $LOCAL_LEXICAL => 1;
Readonly::Scalar my $NON_LOCAL_LEXICAL => 2;

Readonly::Scalar my $LAST_ELEMENT => -1;

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

sub supported_parameters {
    return (
        {
            name            => 'lines',
            description     => 'The maximum number of lines between an open() and a close().',
            default_string  => '9',
            behavior        => 'integer',
            integer_minimum => 1,
        },
    );
}

sub default_severity     { return $SEVERITY_HIGH             }
sub default_themes       { return qw< core pbp maintenance > }
sub applies_to           { return 'PPI::Token::Word'         }

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

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

    # Is it a call to open?
    $OPEN_BUILTIN{$elem->content()} or return;
    return if ! is_function_call($elem);
    my @open_args = parse_arg_list($elem);
    return if 2 > @open_args; # not a valid call to open()

    my ($is_lexical, $fh) = _get_opened_fh($open_args[0]);
    return if not $fh;
    return if $fh =~ m< \A [*]? STD (?: IN|OUT|ERR ) \z >xms;

    for my $close_token ( $self->_find_close_invocations_or_return(
            $elem, $is_lexical ) ) {
        # The $close_token might be a close() or a return()
        #  It doesn't matter which -- both satisfy this policy
        if (is_function_call($close_token)) {
            my @close_args = parse_arg_list($close_token);

            my $close_parameter = $close_args[0];
            if ('ARRAY' eq ref $close_parameter) {
                $close_parameter = ${$close_parameter}[0];
            }
            if ( $close_parameter ) {
                $close_parameter = "$close_parameter";
                return if $fh eq $close_parameter;

                if ( any { m< \A [*] >xms } ($fh, $close_parameter) ) {
                    (my $stripped_fh = $fh) =~ s< \A [*] ><>xms;
                    (my $stripped_parameter = $close_parameter) =~
                        s< \A [*] ><>xms;

                    return if $stripped_fh eq $stripped_parameter;
                }
            }
        }
        elsif ($is_lexical && is_method_call($close_token)) {
            my $tok = $close_token->sprevious_sibling->sprevious_sibling;
            return if $fh eq $tok;
        }
    }

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

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

    my $parent = $self->_get_scope( $elem, $is_lexical );
    return if !$parent; # I can't think of a scenario where this would happen

    my $open_loc = $elem->location;
    # we don't actually allow _lines to be zero or undef, but maybe we will
    my $end_line = $self->{_lines} ? $open_loc->[0] + $self->{_lines} : undef;

    my $closes = $parent->find(sub {
        ##no critic (ProhibitExplicitReturnUndef)
        my ($parent, $candidate) = @_;  ## no critic(Variables::ProhibitReusedNames)
        return undef if $candidate->isa('PPI::Statement::Sub');
        my $candidate_loc = $candidate->location;
        return undef if !defined $candidate_loc->[0];
        return 0 if $candidate_loc->[0] < $open_loc->[0];
        return 0 if $candidate_loc->[0] == $open_loc->[0] && $candidate_loc->[1] <= $open_loc->[1];
        return undef if defined $end_line && $candidate_loc->[0] > $end_line;
        return 0 if !$candidate->isa('PPI::Token::Word');
        return $CLOSE_BUILTIN{ $candidate->content() } || 0;
    });
    return @{$closes || []};
}

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

    my $open_loc = $elem->location;
    my $end_line = ( $self->{_lines} && defined $open_loc->[0] ) ?
        $open_loc->[0] + $self->{_lines} :
        undef;

    while ( my $dad = $elem->parent) {
        $elem = $dad;
        next if not $elem->scope;

        # If we are analyzing something like 'open my $fh ...', the
        # most-local scope suffices. RT #64437
        return $elem if $LOCAL_LEXICAL == $is_lexical;
        next if not defined $end_line;  # Presume search everywhere

        # If we are analyzing something like 'open $fh ...', 'open FH
        # ...', or 'open *FH ...' we need to use a scope that includes
        # the end of the legal range. We just give up and return the
        # current scope if we can not determine any of the locations
        # involved. RT #64437
        return $elem if not $open_loc;
        my $elem_loc = $elem->location
            or return $elem;
        my $last_kid = $elem->child( $LAST_ELEMENT )
            or return $elem;    # What? no children?
        my $last_kid_loc = $last_kid->location
            or return $elem;
        # At this point, the scope we have, even if it is not the
        # correct scope for the file handle, is big enough that if the
        # corresponding close() is outside it, it must be a violation.
        # RT #64437
        return $elem if $last_kid_loc->[0] > $end_line;
    }
    return $elem;   # Whatever the top-level PPI::Node was.
}

sub _get_opened_fh {
    my ($tokens) = shift;

    my $is_lexical;
    my $fh;

    if ( 2 == @{$tokens} ) {
        if ('my' eq $tokens->[0] &&
            $tokens->[1]->isa('PPI::Token::Symbol') &&
            $SCALAR_SIGIL eq $tokens->[1]->raw_type) {

            $is_lexical = $LOCAL_LEXICAL;
            $fh = $tokens->[1];
        }
    }
    elsif (1 == @{$tokens}) {
        my $argument = _unwrap_block( $tokens->[0] );
        if ( $argument->isa('PPI::Token::Symbol') ) {
            my $sigil = $argument->raw_type();
            if ($SCALAR_SIGIL eq $sigil) {
                $is_lexical = $NON_LOCAL_LEXICAL;   # We need to
                                            # distinguish between
                                            # 'open my $fh ...' and
                                            # 'open $fh ...'. RT #64437
                $fh = $argument;
            }
            elsif ($GLOB_SIGIL eq $sigil) {
                $is_lexical = $NOT_LEXICAL;
                $fh = $argument;
            }
        }
        elsif ($argument->isa('PPI::Token::Word') && $argument eq uc $argument) {
            $is_lexical = $NOT_LEXICAL;
            $fh = $argument;
        }
    }

    return ($is_lexical, $fh);
}

sub _unwrap_block {
    my ($element) = @_;

    return $element if not $element->isa('PPI::Structure::Block');

    my @children = $element->schildren();
    return $element if 1 != @children;
    my $child = $children[0];

    return $child if not $child->isa('PPI::Statement');

    my @grandchildren = $child->schildren();
    return $element if 1 != @grandchildren;

    return $grandchildren[0];
}

1;

__END__

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

#line 362

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