File Coverage

blib/lib/Dancer/Plugin/Cache/CHI.pm

Criterion	Covered	Total	%
statement	59	61	96.7
branch	10	12	83.3
condition	4	7	57.1
subroutine	20	21	95.2
pod	0	1	0.0
total	93	102	91.1

package Dancer::Plugin::Cache::CHI;
our $AUTHORITY = 'cpan:YANICK';
# ABSTRACT: Dancer plugin to cache response content (and anything else)
$Dancer::Plugin::Cache::CHI::VERSION = '1.5.0';
use strict;
use warnings;
no warnings qw/ uninitialized /;

use Dancer 1.32 ':syntax';

use Carp;
use CHI;

use Dancer::Plugin;

use Moo;

use Dancer::Factory::Hook;
use Dancer::Response;
use Dancer::SharedData;


my %cache;
my $cache_page; # actually hold the ref to the args
my $cache_page_key_generator = sub {
    return request()->{path_info};
};

hook after => sub {
    return unless $cache_page;

    my $resp = shift;
    cache()->set( $cache_page_key_generator->(),
        {
            status      => $resp->status,
            headers     => $resp->headers_to_array,
            content     => $resp->content
        },
        @$cache_page,
    );

    $cache_page = undef;
};

register cache => sub {
    return  $cache{$_[0]//''} ||= _create_cache( @_ );
};

my $honor_no_cache = 0;

sub _create_cache {
    my $namespace = shift;
    my $args = shift || {};

    Dancer::Factory::Hook->execute_hooks( 'before_create_cache' );

    my %setting = %{ plugin_setting() };

    $setting{namespace} = $namespace if defined $namespace;

    while( my ( $k, $v ) = each %$args ) {
        $setting{$k} = $v;
    }

    $honor_no_cache = delete $setting{honor_no_cache}
        if exists $setting{honor_no_cache};

    return CHI->new(%setting);
}



sub should_skip_cache {
    return unless $honor_no_cache;

    my $req =  Dancer::SharedData->request;

    no warnings 'uninitialized';

    return scalar grep {
        $req->header($_) eq 'no-cache'
    } qw/ Cache-Control Pragma /;
}

register check_page_cache => sub {

    hook before => sub {
        # Instead halt() now we use a more correct method - setting of a
        # response to Dancer::Response object for a more correct returning of
        # some HTTP headers (X-Powered-By, Server)

        my $cached = cache()->get( $cache_page_key_generator->() )
            or return;

        return if should_skip_cache();

        Dancer::SharedData->response(
            Dancer::Response->new(
                ref $cached eq 'HASH'
                ?
                (
                    status       => $cached->{status},
                    headers      => $cached->{headers},
                    content      => $cached->{content}
                )
                :
                ( content => $cached )
            )
        );
    };

};


register cache_page => sub {
    my ( $content, @args ) = @_;

    $cache_page = \@args;

    return $content;
};



register cache_page_key => sub {
    return $cache_page_key_generator->();
};


register cache_page_key_generator => sub {
    $cache_page_key_generator = shift;
};


for my $method ( qw/ set get remove clear compute / ) {
    register 'cache_'.$method => sub {
        return cache()->$method( @_ );
    }
}

Dancer::Factory::Hook->instance->install_hooks(qw/ before_create_cache /);


register_plugin;

__END__