File Coverage

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

Criterion	Covered	Total	%
statement	49	52	94.2
branch	11	14	78.5
condition	4	7	57.1
subroutine	13	14	92.8
pod			n/a
total	77	87	88.5

package Dancer2::Plugin::Cache::CHI;
our $AUTHORITY = 'cpan:YANICK';
# ABSTRACT: Dancer plugin to cache response content (and anything else)
$Dancer2::Plugin::Cache::CHI::VERSION = '1.7.1';
use strict;
use warnings;
use Carp;
use CHI;

use Dancer2::Plugin;

register_hook 'before_create_cache';


my %cache;
my $cache_page; # actually hold the ref to the args
my $cache_page_key_generator = sub {
    return $_[0]->app->request->path;
};

on_plugin_import {
    my $dsl = shift;

    $dsl->app->add_hook(
        Dancer2::Core::Hook->new(
            name => 'after',
            code => sub {
                return unless $cache_page;

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

                $cache_page = undef;
            }
    ));
};

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

my $honor_no_cache = 0;

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

    $dsl->execute_hook( 'plugin.cache_chi.before_create_cache' );

    my %setting = %{
        $dsl->app->config->{plugins}{'Cache::CHI'} || {}
    };

    $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);
}



register check_page_cache => sub {
    my $dsl = shift;

    my $hook = sub {
        my $context = shift;

        # Instead halt() now we use a more correct method - setting of a
        # response to Dancer2::Core::Response object for a more correct returning of
        # some HTTP headers (X-Powered-By, Server)

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

        if ( $honor_no_cache ) {

            my $req =  $dsl->app->request;

            no warnings 'uninitialized';

            return if grep {
                # eval is there to protect from a regression in Dancer 1.31
                # where headers can be undef
                eval { $req->header($_) eq 'no-cache' }
            } qw/ Cache-Control Pragma /;
        }

        $context->set_response(
        	Dancer2::Core::Response->new(
                is_halted => 1,
                ref $cached eq 'HASH'
                ?
                (
                    status       => $cached->{status},
                    headers      => $cached->{headers},
                    content      => $cached->{content}
                )
                :
                ( content => $cached )
            )
		);
    };

    $dsl->app->add_hook( Dancer2::Core::Hook->new(
        name => 'before',
        code => $hook,
    ));
};


register cache_page => sub {
    shift;

    my ( $content, @args ) = @_;

    $cache_page = \@args;

    return $content;
};



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


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


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


register_plugin for_versions => [1,2];

1;

__END__