File Coverage

blib/lib/Dancer/Session/Memcached/Fast.pm

Criterion	Covered	Total	%
statement	24	73	32.8
branch	0	10	0.0
condition	0	9	0.0
subroutine	8	22	36.3
pod	8	8	100.0
total	40	122	32.7

use strict;
use warnings;

package Dancer::Session::Memcached::Fast;

# ABSTRACT: Cache::Memcached::Fast based session backend for Dancer

our $VERSION = '0.002';    # VERSION

use mro;
use Carp;
use Cache::Memcached::Fast;
use CBOR::XS qw(encode_cbor decode_cbor);
use Dancer::Config qw(setting);
use parent 'Dancer::Session::Abstract';

my $setting_prefix = 'session_memcached_fast_';

sub _setting {
    setting( $setting_prefix . shift(), @_ );
}

sub _config {
    Dancer::Config::settings();
}

sub new {
    shift->next::method(@_);
}

sub init {
    my $self = shift;

    $self->next::method(@_);

    my $servers = _setting('servers');
    croak "The setting session_memcached_servers must be defined"
      unless defined $servers;

    $servers = [ split /,/, $servers ];

    $self->{cmf} = Cache::Memcached::Fast->new(
        {
            servers    => $servers,
            check_args => '',
        }
    );

    $self;
}

sub _engine {
    Dancer::engine('session');
}

sub _mkns {
    my $id = shift;
    my $ns = _setting('namespace') || _config->{appname};
    return "$ns#$id";
}

sub _boot {
    my ( $class, %config ) = @_;
    my $engine = _engine;
    bless {
        id  => undef,
        cmf => $engine->{cmf},
        %config
    } => $class;
}

sub _set_expire {
    my ( $self, $expire ) = @_;
    $expire //= setting('session_expires');
    if ($expire) {
        if ( $expire !~ m{^\d+$} ) {
            $expire = Dancer::Cookie::_parse_duration($expire);
        }
        $expire -= time;
    }
    else {
        $expire = undef;
    }
    $self->{cmf}->set( '' => time, $expire );
}

sub create {
    my ($class) = @_;
    my $self = $class->_boot( id => $class->build_id );
    $self->{cmf}->namespace( _mkns( $self->id ) );
    $self->_set_expire;
    $self;
}

sub retrieve {
    my ( $class, $id ) = @_;
    my $self = $class->_boot( id => $id );
    $self->{cmf}->namespace( _mkns( $self->id ) );
    my $time = $self->{cmf}->get('');
    return unless defined $time and $time =~ m{^\d+$};
    $self->_set_expire;
    $self;
}

sub get_value {
    my ( $self, $key ) = @_;
    my $value = $self->{cmf}->get($key);
    return unless defined $value;
    decode_cbor $value;
}

sub set_value {
    my ( $self, $key, $value ) = @_;
    $self->{cmf}->set( $key => encode_cbor $value);
}

sub destroy {
    my ($self) = @_;
    $self->{cmf}->flush_all;
    undef;
}

sub flush {
    my $self = shift;
    $self->{cmf}->nowait_push;
    $self;
}

1;

__END__