File Coverage

blib/lib/Redis/ScriptCache.pm

Criterion	Covered	Total	%
statement	23	82	28.0
branch	0	30	0.0
condition	0	8	0.0
subroutine	8	17	47.0
pod	7	7	100.0
total	38	144	26.3

package Redis::ScriptCache;
use strict;
use warnings;
use 5.10.0;

our $VERSION = '0.05';

use File::Basename;
use File::Spec qw(
    catdir
    splitdir
);
use Carp;
use Digest::SHA1 'sha1_hex';

use Class::XSAccessor {
    getters => [qw(
        redis_conn
        script_dir
        _script_cache
    )],
};

sub new {
    my $class = shift;
    my $self = bless { @_ }, $class;

    # initialize the cache
    $self->{_script_cache} = {};
    # redis_conn is compulsory
    $self->redis_conn
        or croak('Need Redis connection');
    # canonicalize script_dir
    $self->_set_script_dir;

    return $self;
}

sub _set_script_dir {
    my( $self, $script_dir ) = @_;
    my $script_dir_to_set = $script_dir // $self->script_dir // undef;
    $self->{script_dir} = File::Spec->catdir( File::Spec->splitdir( $script_dir_to_set ) )
        if $script_dir_to_set;
    return $self;
}

sub register_all_scripts {
    my $self = shift;
    my %args = @_;

    $self->_set_script_dir( $args{script_dir} )
        if $args{script_dir};

    if ( $self->script_dir ) {
        for my $file (glob($self->script_dir . '/*.lua')) {
            $self->register_file(basename($file));
        }
        return $self->scripts;
    } else {
        croak('No script_dir specified');
    }
}

sub register_script {
    my ($self, $script_name, $script) = @_;
    $script = $$script if ref($script);

    $self->{_script_cache}{$script_name} = [ sha1_hex($script), $script ];

    return $script_name;
}

sub run_script {
    my ($self, $script_name, $args) = @_;

    my $conn = $self->redis_conn;
    my $script = $self->_script_cache->{$script_name}
        // croak("Unknown script $script_name");

    my @result;
    my $try = sub {
        $conn->evalsha($$script[0], $args ? @$args : (0));
    };
    my $wantarray = wantarray;
    if ( $wantarray ) {
        @result = eval { $try->() };
    }
    elsif ( defined $wantarray ) {
        $result[0] = eval { $try->() };
    }
    else {
        eval { $try->() };
    }
    if ( $@ ) {
        croak $@ unless $@ =~ /NOSCRIPT/;
        return $conn->eval($$script[1], $args ? @$args : (0));
    };

    return unless defined $wantarray;
    return $wantarray ? @result : $result[0];
}

sub register_file {
    my ($self, $path_to_file) = @_;
    open my $fh, '<', File::Spec->catdir( $self->script_dir, $path_to_file )
        or croak "error opening $path_to_file: $!";

    my $script_name = basename( $path_to_file );
    $script_name =~ s/\.lua$//;
    my $script = do { local $/; <$fh> };
    return $self->register_script($script_name, $script);
}

sub scripts {
    my ($self) = @_;
    return keys %{ $self->_script_cache };
}

sub flush_all_scripts {
    my ($self) = @_;
    eval {
        $self->redis_conn->script_flush();
        $self->{_script_cache} = {};
    };
    if ( $@ ) {
        croak "redis script_flush failed: $@";
    };
    return $self;
}

1;

__END__