package Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters;

use 5.010001;
use strict;
use warnings;
use Readonly;

use Perl::Critic::Utils qw{
    :booleans :characters :severities :data_conversion
};
use parent 'Perl::Critic::Policy';

our $VERSION = '1.156';

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

Readonly::Hash my %DESCRIPTIONS => (
    $QUOTE    => q{Single-quote used as quote-like operator delimiter},
    $DQUOTE   => q{Double-quote used as quote-like operator delimiter},
    $BACKTICK => q{Back-quote (back-tick) used as quote-like operator delimiter},
);

Readonly::Scalar my $EXPL =>
    q{Using quotes as delimiters for quote-like operators obfuscates code};

Readonly::Array my @OPERATORS => qw{ m q qq qr qw qx s tr y };

Readonly::Hash my %INFO_RETRIEVERS_BY_PPI_CLASS => (
    'PPI::Token::Quote::Literal'        => \&_info_for_single_character_operator,
    'PPI::Token::Quote::Interpolate'    => \&_info_for_two_character_operator,
    'PPI::Token::QuoteLike::Command'    => \&_info_for_two_character_operator,
    'PPI::Token::QuoteLike::Regexp'     => \&_info_for_two_character_operator,
    'PPI::Token::QuoteLike::Words'      => \&_info_for_two_character_operator,
    'PPI::Token::Regexp::Match'         => \&_info_for_match,
    'PPI::Token::Regexp::Substitute'    => \&_info_for_single_character_operator,
    'PPI::Token::Regexp::Transliterate' => \&_info_for_transliterate,
);

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

sub supported_parameters {
    return (
        {
            name               => 'single_quote_allowed_operators',
            description        =>
                'The operators to allow single-quotes as delimiters for.',
            default_string     => 'm s qr qx',
            behavior           => 'enumeration',
            enumeration_values => [ @OPERATORS ],
            enumeration_allow_multiple_values => 1,
        },
        {
            name               => 'double_quote_allowed_operators',
            description        =>
                'The operators to allow double-quotes as delimiters for.',
            default_string     => $EMPTY,
            behavior           => 'enumeration',
            enumeration_values => [ @OPERATORS ],
            enumeration_allow_multiple_values => 1,
        },
        {
            name               => 'back_quote_allowed_operators',
            description        =>
                'The operators to allow back-quotes (back-ticks) as delimiters for.',
            default_string     => $EMPTY,
            behavior           => 'enumeration',
            enumeration_values => [ @OPERATORS ],
            enumeration_allow_multiple_values => 1,
        },
    );
}

sub default_severity { return $SEVERITY_MEDIUM       }
sub default_themes   { return qw( core maintenance ) }

sub applies_to {
    return qw{
        PPI::Token::Quote::Interpolate
        PPI::Token::Quote::Literal
        PPI::Token::QuoteLike::Command
        PPI::Token::QuoteLike::Regexp
        PPI::Token::QuoteLike::Words
        PPI::Token::Regexp::Match
        PPI::Token::Regexp::Substitute
        PPI::Token::Regexp::Transliterate
    };
}

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

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

    $self->{_allowed_operators_by_delimiter} = {
        $QUOTE    => $self->_single_quote_allowed_operators(),
        $DQUOTE   => $self->_double_quote_allowed_operators(),
        $BACKTICK => $self->_back_quote_allowed_operators(),
    };

    return $TRUE;
}

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

sub _single_quote_allowed_operators {
    my ( $self ) = @_;

    return $self->{_single_quote_allowed_operators};
}

sub _double_quote_allowed_operators {
    my ( $self ) = @_;

    return $self->{_double_quote_allowed_operators};
}

sub _back_quote_allowed_operators {
    my ( $self ) = @_;

    return $self->{_back_quote_allowed_operators};
}

sub _allowed_operators_by_delimiter {
    my ( $self ) = @_;

    return $self->{_allowed_operators_by_delimiter};
}

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

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

    my $info_retriever = $INFO_RETRIEVERS_BY_PPI_CLASS{ ref $elem };
    return if not $info_retriever;

    my ($operator, $delimiter) = $info_retriever->( $elem );

    my $allowed_operators =
        $self->_allowed_operators_by_delimiter()->{$delimiter};
    return if not $allowed_operators;

    if ( not $allowed_operators->{$operator} ) {
        return $self->violation( $DESCRIPTIONS{$delimiter}, $EXPL, $elem );
    }

    return;
}

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

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

    ## no critic (ProhibitParensWithBuiltins)
    return ( substr ($elem, 0, 1), substr ($elem, 1, 1) );
    ## use critic
}

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

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

    ## no critic (ProhibitParensWithBuiltins)
    return ( substr ($elem, 0, 2), substr ($elem, 2, 1) );
    ## use critic
}

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

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

    if ( $elem =~ m/ ^ m /xms ) {
        return ('m', substr $elem, 1, 1);
    }

    return ('m', q{/});
}

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

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

    if ( $elem =~ m/ ^ tr /xms ) {
        return ('tr', substr $elem, 2, 1);
    }

    return ('y', substr $elem, 1, 1);
}


1;

__END__

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

=pod

=for stopwords Schwern

=head1 NAME

Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters - Don't use quotes (C<'>, C<">, C<`>) as delimiters for the quote-like operators.


=head1 AFFILIATION

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


=head1 DESCRIPTION

With the obvious exception of using single-quotes to prevent
interpolation, using quotes with the quote-like operators kind of
defeats the purpose of them and produces obfuscated code, causing
problems for future maintainers and their editors/IDEs.

    $x = q"q";                #not ok
    $x = q'q';                #not ok
    $x = q`q`;                #not ok

    $x = qq"q";               #not ok
    $x = qr"r";               #not ok
    $x = qw"w";               #not ok

    $x = qx`date`;            #not ok

    $x =~ m"m";               #not ok
    $x =~ s"s"x";             #not ok
    $x =~ tr"t"r";            #not ok
    $x =~ y"x"y";             #not ok

    $x =~ m'$x';              #ok
    $x =~ s'$x'y';            #ok
    $x = qr'$x'm;             #ok
    $x = qx'finger foo@bar';  #ok


=head1 CONFIGURATION

This policy has three options: C<single_quote_allowed_operators>,
C<double_quote_allowed_operators>, and
C<back_quote_allowed_operators>, which control which operators are
allowed to use each of C<'>, C<">, C<`> as delimiters, respectively.

The values allowed for these options are a whitespace delimited
selection of the C<m>, C<q>, C<qq>, C<qr>, C<qw>, C<qx>, C<s>, C<tr>,
and C<y> operators.

By default, double quotes and back quotes (backticks) are not allowed
as delimiters for any operators and single quotes are allowed as
delimiters for the C<m>, C<qr>, C<qx>, and C<s> operators.  These
defaults are equivalent to having the following in your
F<.perlcriticrc>:

    [ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters]
    single_quote_allowed_operators = m s qr qx
    double_quote_allowed_operators =
    back_quote_allowed_operators =


=head1 SUGGESTED BY

Michael Schwern


=head1 AUTHOR

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


=head1 COPYRIGHT

Copyright (c) 2007-2011 Elliot Shank.

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 :