File Coverage

blib/lib/Redis/ScriptCache.pm
Criterion Covered Total %
statement 18 69 26.0
branch 0 22 0.0
condition 0 5 0.0
subroutine 6 14 42.8
pod 7 7 100.0
total 31 117 26.5


line stmt bran cond sub pod time code
1             package Redis::ScriptCache;
2 2     2   61090 use strict;
  2         4  
  2         65  
3 2     2   11 use warnings;
  2         4  
  2         106  
4              
5             our $VERSION = '0.04';
6              
7 2     2   11 use File::Basename;
  2         9  
  2         356  
8 2         49 use File::Spec qw(
9             catdir
10             splitdir
11 2     2   13 );
  2         4  
12 2     2   11 use Carp;
  2         4  
  2         178  
13              
14             use Class::XSAccessor {
15 2         43 getters => [qw(
16             redis_conn
17             script_dir
18             _script_cache
19             )],
20 2     2   3016 };
  2         15055  
21              
22             sub new {
23 0     0 1   my $class = shift;
24 0           my $self = bless { @_ }, $class;
25              
26             # initialize the cache
27 0           $self->{_script_cache} = {};
28             # redis_conn is compulsory
29 0 0         $self->redis_conn
30             or croak('Need Redis connection');
31             # canonicalize script_dir
32 0           $self->_set_script_dir;
33              
34 0           return $self;
35             }
36              
37             sub _set_script_dir {
38 0     0     my( $self, $script_dir ) = @_;
39 0   0       my $script_dir_to_set = $script_dir // $self->script_dir // undef;
      0        
40 0 0         $self->{script_dir} = File::Spec->catdir( File::Spec->splitdir( $script_dir_to_set ) )
41             if $script_dir_to_set;
42 0           return $self;
43             }
44              
45             sub register_all_scripts {
46 0     0 1   my $self = shift;
47 0           my %args = @_;
48              
49             $self->_set_script_dir( $args{script_dir} )
50 0 0         if $args{script_dir};
51              
52 0 0         if ( $self->script_dir ) {
53 0           for my $file (glob($self->script_dir . '/*.lua')) {
54 0           $self->register_file(basename($file));
55             }
56 0           return $self->scripts;
57             } else {
58 0           croak('No script_dir specified');
59             }
60             }
61              
62             sub register_script {
63 0     0 1   my ($self, $script_name, $script) = @_;
64 0 0         my $script_ref = ref($script) ? $script : \$script;
65             return $script_name
66 0 0         if exists $self->{_script_cache}->{$script_name};
67              
68 0           my $sha;
69             eval {
70 0           $sha = $self->redis_conn->script_load($$script_ref);
71 0           1;
72 0 0         } or do {
73 0           croak("redis script_load failed: $@");
74             };
75 0           $self->{_script_cache}->{$script_name} = $sha;
76              
77 0           return $script_name;
78             }
79              
80             sub run_script {
81 0     0 1   my ($self, $script_name, $args) = @_;
82            
83 0           my $conn = $self->redis_conn;
84 0           my $sha = $self->_script_cache->{$script_name};
85              
86 0 0         croak("Unknown script $script_name") if !$sha;
87              
88 0 0         return $conn->evalsha($sha, ($args ? (@$args) : (0)));
89             }
90              
91             sub register_file {
92 0     0 1   my ($self, $path_to_file) = @_;
93 0 0         open my $fh, '<', File::Spec->catdir( $self->script_dir, $path_to_file )
94             or croak "error opening $path_to_file: $!";
95              
96 0           my $script_name = basename( $path_to_file );
97 0           $script_name =~ s/\.lua$//;
98 0           my $script = do { local $/; <$fh> };
  0            
  0            
99 0           return $self->register_script($script_name, $script);
100             }
101              
102             sub scripts {
103 0     0 1   my ($self) = @_;
104 0           return keys %{ $self->_script_cache };
  0            
105             }
106              
107             sub flush_all_scripts {
108 0     0 1   my ($self) = @_;
109             eval {
110 0           $self->redis_conn->script_flush();
111 0           1;
112 0 0         } or do {
113 0           croak "redis script_flush failed: $@";
114             };
115 0           $self->{_script_cache} = {};
116 0           return $self;
117             }
118              
119             1;
120              
121             __END__