File Coverage

blib/lib/Dancer2/Plugin/Redis.pm

Criterion	Covered	Total	%
statement	53	99	53.5
branch	9	50	18.0
condition	0	18	0.0
subroutine	16	27	59.2
pod	7	7	100.0
total	85	201	42.2

package Dancer2::Plugin::Redis;
use strictures 1;
# ABSTRACT: Perl Dancer2 plugin for interaction with key-value-store Redis.
#
# This file is part of Dancer2-Plugin-Redis
#
# This software is Copyright (c) 2018 by BURNERSK .
#
# This is free software, licensed under:
#
#   The MIT (X11) License
#

BEGIN {
  our $VERSION = '0.008'; # VERSION: generated by DZP::OurPkgVersion
}

use Carp qw( carp croak );
use Dancer2::Core::Types qw( Maybe InstanceOf );
use Dancer2::Plugin 0.200000;
use Redis;
use Safe::Isa;
use Try::Tiny;
use Type::Tiny;


############################################################################

my $TYPE_SERIALIZATIONOBJECT = Type::Tiny->new(
  name       => 'SerializationObject',
  constraint => sub { $_->$_call_if_object( 'does' => 'Dancer2::Plugin::Redis::SerializationRole' ) },
  message => sub { qq{$_ does not consume a SerializationRole} },
);

has _serialization => (
  is      => 'lazy',
  isa     => Maybe [ $TYPE_SERIALIZATIONOBJECT ],
);

sub _build__serialization {
    my ($dsl1) = @_;
    my $conf = $dsl1->config;
    my $serialization;

    # Setup serialization.
    if ( my $serialization_module = delete $conf->{serialization}{module} ) {
      $serialization_module =~ s/^/Dancer2::Plugin::Redis::Serialization::/
        if $serialization_module !~ m/^Dancer2::Plugin::Redis::Serialization::/;
      croak qq{Invalid serialization module: $serialization_module}
        if $serialization_module !~ m/^Dancer2::Plugin::Redis::Serialization::[a-zA-Z][a-zA-Z0-9_]*$/;
      try {
        eval "require $serialization_module" or croak $@;
        $serialization = "$serialization_module"->new( %{ $conf->{serialization} } );
      }
      catch {
        $dsl1->error(qq{Unable to set up serialization '$serialization_module': $_});
      };
    }
    return $serialization;
};

has _redis => (
  is      => 'lazy',
  isa     => InstanceOf ['Redis', 't::TestApp::RedisMock'],
);

sub _build__redis {
    my ($dsl2) = @_;
    my $conf = $dsl2->config;

    if ( $conf->{test_mock} ) {
      require t::TestApp::RedisMock;
      return t::TestApp::RedisMock->new;
    }

    my %opts;

    # Build Redis->new settings.
    for (qw( server sock password reconnect every name debug )) {
      $opts{$_} = $conf->{$_} if exists $conf->{$_};
    }

    # Cleanup settings.
    delete $opts{server} if $opts{sock};   # prefer UNIX/Linux sockets.
    delete $opts{sock}   if $opts{server};
    delete $opts{password} if exists $opts{password} && ( !defined $opts{password} || $opts{password} eq '' );
    delete $opts{name} unless $opts{name};

    # Validate reconnect settings.
    if ( ( exists $opts{reconnect} || exists $opts{every} ) && ( !$opts{reconnect} || !$opts{every} ) ) {
      $dsl2->error(q{Incomplete Redis configuration for 'reconnect' and 'every', skipping...});
      delete $opts{reconnect};
      delete $opts{every};
    }

    # Validate on_connect settings.
    if ( exists $conf->{on_connect} ) {
      if ( !exists &{ $conf->{on_connect} } ) {
        $dsl2->error(q{Invalid Redis configuration for 'on_connect', skipping...});
      }
      else {
        $opts{on_connect} = \&{ $conf->{on_connect} };
      }
    }

    # Validate connection settings.
    $dsl2->error(q{Incomplete Redis configuration: required is either 'server' or 'sock'})
      if !$opts{server} && !$opts{sock};

    return Redis->new(%opts);
}

############################################################################

sub _plugin {
  shift->redis_plugin;
}

sub redis_plugin {
  my ($dsl) = @_;
  return $dsl;
}

############################################################################

sub _get {
  shift->redis_get(@_);
}

sub redis_get {
  my ( $dsl, $key ) = @_;
  croak q{Redis key is required} unless $key;
  my $data = $dsl->_redis->get($key);
  if ( my $serialization = $dsl->_serialization ) {
    $data = $serialization->decode($data);
  }
  return $data;
}

############################################################################

sub _mget {
  shift->redis_mget(@_);
}

sub redis_mget {
  my ( $dsl, @keys ) = @_;
  croak q{Redis key is required} unless scalar @keys;
  my @data = $dsl->_redis->mget(@keys);
  if ( my $serialization = $dsl->_serialization ) {
    $data[$_] = $serialization->decode( $data[$_] ) for ( 0 .. scalar @data );
  }
  return @data;
}

############################################################################

sub _set {
  shift->redis_set(@_);
}

sub redis_set {
  my ( $dsl, $key, $data ) = @_;
  croak q{Redis key is required} unless $key;
  if ( my $serialization = $dsl->_serialization ) {
    $data = $serialization->encode($data);
  }
  return $dsl->_redis->set( $key => $data );
}

############################################################################

sub _mset {
  shift->redis_mset(@_);
}

sub redis_mset {
  my ( $dsl, %key_data ) = @_;
  croak q{Redis key is required} unless scalar %key_data;
  if ( my $serialization = $dsl->_serialization ) {
    $key_data{$_} = $serialization->encode( $key_data{$_} ) for ( keys %key_data );
  }
  return $dsl->_redis->mset(%key_data);
}

############################################################################

sub _expire {
  shift->redis_expire(@_);
}

sub redis_expire {
  my ( $dsl, $key, $timeout ) = @_;
  croak q{Redis key is required} unless $key;
  return $dsl->_redis->persist($key) unless $timeout;
  return $dsl->_redis->expire( $key => $timeout );
}

############################################################################

sub _del {
  shift->redis_del(@_);
}

sub redis_del {
  my ( $dsl, $key ) = @_;
  croak q{Redis key is required} unless $key;
  return $dsl->_redis->del($key);
}

############################################################################

plugin_keywords 'redis_plugin', 'redis_get', 'redis_mget', 'redis_set',
  'redis_mset', 'redis_expire', 'redis_del';


############################################################################


1;

__END__