File Coverage

blib/lib/WWW/Mechanize/Cached.pm

Criterion	Covered	Total	%
statement	72	97	74.2
branch	28	58	48.2
condition	7	15	46.6
subroutine	14	16	87.5
pod	1	2	50.0
total	122	188	64.8

package WWW::Mechanize::Cached;

use Moo 1.004005;
use warnings FATAL => 'all';

our $VERSION = '2.00';

use Carp                         qw( carp croak );
use Module::Runtime              qw( use_module );
use MooX::Types::MooseLike::Base qw( AnyOf Bool Enum Maybe );
use Storable                     qw( nfreeze thaw );

use namespace::clean;

extends 'WWW::Mechanize';

has is_cached        => ( is => 'rw', isa => Maybe [Bool], default => undef );
has positive_cache   => ( is => 'rw', isa => Bool, default => 1 );
has ref_in_cache_key => ( is => 'rw', isa => Bool, default => 0 );
has _verbose_dwarn   => ( is => 'rw', isa => Bool, default => 0 );
has _last_request    => ( is => 'rw' );

has [qw/ cache_undef_content_length cache_zero_content_length /] =>
    ( is => 'rw', isa => AnyOf [ Bool, Enum ['warn'] ], default => 0 );

has cache_mismatch_content_length => (
    is      => 'rw',
    isa     => AnyOf [ Bool, Enum ['warn'] ],
    default => 'warn',
);

has cache => ( is => 'lazy', isa => \&_isa_warn_cache );

sub FOREIGNBUILDARGS {
    my ( $class, %args ) = @_;

    # WWW::Mechanize/LWP::UserAgent would complain about these
    for my $attribute (
        qw(
        is_cached
        positive_cache
        ref_in_cach_key
        _verbose_dwarn
        cache_undef_content_length
        cache_zero_content_length
        cache_mismatch_content_length
        cache
        )
    ) {
        delete $args{$attribute};
    }

    return %args;
}

sub _isa_warn_cache {
    return
            if 'HASH' ne ref $_[0]
        and $_[0]->can('get')
        and $_[0]->can('set');
    carp 'The cache param must be an initialized cache object';
    $_[0] = undef;
}

sub _build_cache {
    my $self = shift;

    if ( eval { use_module('Cache::FileCache') && use_module('File::XDG') } )
    {
        my $cache_root = File::XDG->new(
            name => 'WWW-Mechanize-Cached',
            api  => 1,
        )->cache_home;
        $cache_root->mkdir( { mode => 0700 } );
        chmod 0700, "$cache_root";
        return Cache::FileCache->new(
            {
                default_expires_in => '1d',
                namespace          => 'www-mechanize-cached',
                cache_root         => "$cache_root",
                directory_umask    => 077,
            }
        );
    }

    return CHI->new(
        driver     => 'File',
        expires_in => '1d',
        namespace  => 'www-mechanize-cached',
    ) if eval { use_module('CHI') };

    croak(    'Could not create a default cache.'
            . 'Please make sure either CHI or Cache::FileCache are installed or configure manually as appropriate'
    );
}

around _make_request => sub {
    my ( $orig, $self, $request ) = splice @_, 0, 3;
    my $req = $request;

    $self->is_cached(0);

    # An odd line to need.
    # No idea what purpose this serves?  OALDERS
    $self->{proxy} = {} unless defined $self->{proxy};    ## no critic

    # RT #56757
    if ( !$self->ref_in_cache_key ) {
        my $clone = $request->clone;
        $clone->header( Referer => undef );
        $req = $clone->as_string;
    }

    my $response = $self->cache->get($req);

    if ($response) {
        $response = thaw($response);
    }
    if ( $self->_cache_ok($response) ) {
        $self->is_cached(1);
        $self->_last_request($req);
        return $response;
    }

    $response = $self->$orig( $request, @_ );

    # decode strips some important headers.
    my $headers = $response->headers->clone;

    my $should_cache = $self->_response_cache_ok( $response, $headers );

    # http://rt.cpan.org/Public/Bug/Display.html?id=42693
    $response->decode();
    delete $response->{handlers};    ## no critic

    if ($should_cache) {
        $self->_last_request($req);
        $self->cache->set( $req, nfreeze($response) );
    }

    return $response;
};

sub invalidate_last_request {
    my $self = shift;
    return unless $self->is_cached;

    my $request = $self->_last_request;
    return unless $request;

    $self->cache->remove($request);
    return $self->is_cached( $self->cache->get($request) ? 1 : 0 );
}

sub _dwarn_filter {
    return {
        hide_keys => [
            qw( _content cookie content set-cookie handlers cookie_jar cache req res page_stack )
        ]
    };

}

sub _dwarn {
    my $self    = shift;
    my $message = shift;

    return unless my $handler = $self->{onwarn};    ## no critic

    return if $self->quiet;

    if ( $self->_verbose_dwarn ) {
        my $payload = {
            self    => $self,
            message => $message,
            debug   => \@_,
        };
        require Data::Dump;
        return $handler->( Data::Dump::dumpf( $payload, \&_dwarn_filter ) );
    }
    else {
        return $handler->($message);
    }
}

sub _response_cache_ok {
    my $self     = shift;
    my $response = shift;
    my $headers  = shift;

    return 0 if !$response;
    return 1 if !$self->positive_cache;

    return 0 if $response->code < 200;
    return 0 if $response->code > 301;

    my $size;
    {
        if ( $headers->header('Client-Transfer-Encoding') ) {
            my @cte = $headers->header('Client-Transfer-Encoding');
            for my $cte (@cte) {

                # Transfer-Encoding = chunked means document consistency
                # is independent of Content-Length value,
                # and that Content-Length can be safely ignored.
                # Its not obvious how the lower levels represent a
                # failed chunked-transfer yet.
                # But its safe to say relying on content-length proves pointless.
                return 1 if $cte eq 'chunked';
            }
        }

        $size = $headers->{'content-length'};
    }

    if ( not defined $size ) {
        if ( $self->cache_undef_content_length . q{} eq q{warn} ) {
            $self->_dwarn(
                      q[Content-Length header was undefined, not caching]
                    . q[ (E=WWW_MECH_CACHED_CONTENTLENGTH_MISSING)],
                $headers
            );
            return 0;
        }
        if ( $self->cache_undef_content_length == 0 ) {
            return 0;
        }
    }

    if ( defined $size and $size == 0 ) {
        if ( $self->cache_zero_content_length . q{} eq q{warn} ) {
            $self->_dwarn(
                      q{Content-Length header was 0, not caching}
                    . q{ (E=WWW_MECH_CACHED_CONTENTLENGTH_ZERO)},
                $headers
            );
            return 0;
        }
        if ( $self->cache_zero_content_length == 0 ) {
            return 0;
        }
    }

    if (    defined $size
        and $size != 0
        and $size != length( $response->content ) ) {
        if ( $self->cache_mismatch_content_length . "" eq "warn" ) {
            $self->_dwarn(
                q{Content-Length header did not match contents actual length, not caching}
                    . q{ (E=WWW_MECH_CACHED_CONTENTLENGTH_MISSMATCH)} );
            return 0;
        }
        if ( $self->cache_mismatch_content_length == 0 ) {
            return 0;
        }
    }

    return 1;
}

sub _cache_ok {

    my $self     = shift;
    my $response = shift;

    return 0 if !$response;
    return 1 if !$self->positive_cache;

    return 0 if $response->code < 200;
    return 0 if $response->code > 301;

    return 1;
}

no warnings;
"We miss you, Spoon";    ## no critic

# ABSTRACT: Cache response to be polite

__END__