File Coverage

blib/lib/Perl/Critic/Policy/HTTPCookies.pm

Criterion	Covered	Total	%
statement	36	37	97.3
branch	11	12	91.6
condition	13	18	72.2
subroutine	11	12	91.6
pod	4	5	80.0
total	75	84	89.2

package Perl::Critic::Policy::HTTPCookies;
$Perl::Critic::Policy::HTTPCookies::VERSION = '0.52';
use strict;
use warnings;

use parent 'Perl::Critic::Policy';

use Perl::Critic::Utils qw( :classification :severities );
use Readonly ();
use Scalar::Util 'blessed';

Readonly::Scalar my $DESC => 'Use of HTTP::Cookies';
Readonly::Scalar my $EXPL => 'HTTP::Cookies does not respect Public Suffix';

sub supported_parameters    {}
sub default_severity        { $SEVERITY_MEDIUM }
sub default_themes          { qw( http lwp ) }
# TODO: Review "applies_to"
sub applies_to              { 'PPI::Token::Word' }

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

    # HTTP::Cookies->new
    if ( _is_constructor($elem, 'HTTP::Cookies') ) {
        return $self->violation( $DESC, $EXPL, $elem );
    }

    # LWP::UserAgent->new with default cookie jar
    elsif ( _is_constructor($elem, 'LWP::UserAgent') ) {
        my $args_elem = $elem->snext_sibling->snext_sibling->snext_sibling;
        if ( blessed $args_elem && $args_elem->isa('PPI::Structure::List') ) {
            foreach my $expression ($args_elem->schildren) {
                # $expression isa PPI::Statement::Expression
                foreach my $token ($expression->schildren) {
                    # TODO: Check the token's type, not just its content
                    if ($token =~ /cookie_jar/) {
                        my $possible_operator = $token->snext_sibling;
                        if (
                            blessed $possible_operator
                            && $possible_operator->isa('PPI::Token::Operator')
                            && $possible_operator =~ /^(?:=>|,)$/
                        ) {
                            my $possible_hashref = $possible_operator->snext_sibling;
                            if (
                                blessed $possible_hashref
                                && $possible_hashref->isa('PPI::Structure')
                                && $possible_hashref->braces eq '{}'
                            ) {
                                return $self->violation( $DESC, $EXPL, $elem );
                            }
                        }
                    }
                }
            }
        }
    }

    return;
}

sub _is_constructor {
    my ($elem, $class_name) = @_;
    return (
        $elem eq $class_name
        && is_class_name($elem)
        && $elem->snext_sibling eq '->'
        && $elem->snext_sibling->snext_sibling eq 'new'
    );
}

1;
__END__

=head1 NAME

Perl::Critic::Policy::HTTPCookies - Avoid using HTTP::Cookies

=head1 VERSION

version 0.52

=head1 DESCRIPTION

This module provides L<< Perl::Critic >> policies to detect the use of
L<< HTTP::Cookies >>.

HTTP::Cookies takes a very lenient approach to setting cookies that does
not work well with today's Internet:
L<< https://github.com/libwww-perl/http-cookies/pull/7 >>

Consider using L<< HTTP::CookieJar >> or L<< HTTP::CookieJar::LWP >>
instead.

=head1 BUG REPORTS

Please submit bug reports to L<<
https://rt.cpan.org/Public/Dist/Display.html?Name=Perl-Critic-Policy-HTTPCookies
>>.

If you would like to send patches, please send a git pull request to L<<
mailto:[e-mail] >>.

=head1 AUTHOR

Tom Hukins