line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Redis::Script; |
2
|
3
|
|
|
3
|
|
122732
|
use 5.008005; |
|
3
|
|
|
|
|
6
|
|
3
|
3
|
|
|
3
|
|
11
|
use strict; |
|
3
|
|
|
|
|
3
|
|
|
3
|
|
|
|
|
61
|
|
4
|
3
|
|
|
3
|
|
7
|
use warnings; |
|
3
|
|
|
|
|
7
|
|
|
3
|
|
|
|
|
65
|
|
5
|
3
|
|
|
3
|
|
7
|
use Exporter 'import'; |
|
3
|
|
|
|
|
3
|
|
|
3
|
|
|
|
|
126
|
|
6
|
|
|
|
|
|
|
our @EXPORT_OK = ('redis_eval'); |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $VERSION = "0.01"; |
9
|
|
|
|
|
|
|
|
10
|
3
|
|
|
3
|
|
1223
|
use Digest::SHA qw(sha1_hex); |
|
3
|
|
|
|
|
6577
|
|
|
3
|
|
|
|
|
1029
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub new { |
13
|
0
|
|
|
0
|
0
|
|
my ($class, %args) = @_; |
14
|
0
|
|
|
|
|
|
my $self = bless { |
15
|
|
|
|
|
|
|
use_evalsha => 1, |
16
|
|
|
|
|
|
|
%args, |
17
|
|
|
|
|
|
|
}, $class; |
18
|
|
|
|
|
|
|
|
19
|
0
|
|
|
|
|
|
return $self; |
20
|
|
|
|
|
|
|
} |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub eval { |
23
|
0
|
|
|
0
|
1
|
|
my ($self, $redis, $keys, $args) = @_; |
24
|
0
|
0
|
|
|
|
|
if ($self->{use_evalsha}) { |
25
|
0
|
|
|
|
|
|
my $sha = $self->sha1; |
26
|
0
|
|
|
|
|
|
my $ret = eval { $redis->evalsha($sha, scalar(@$keys), @$keys, @$args) }; |
|
0
|
|
|
|
|
|
|
27
|
0
|
0
|
|
|
|
|
if (my $err = $@) { |
28
|
0
|
0
|
|
|
|
|
die $err if $err !~ /\[evalsha\] NOSCRIPT No matching script/i; |
29
|
|
|
|
|
|
|
} else { |
30
|
0
|
0
|
0
|
|
|
|
return (wantarray && ref $ret eq 'ARRAY') ? @$ret : $ret; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
0
|
|
|
|
|
|
my $ret = $redis->eval($self->{script}, scalar(@$keys), @$keys, @$args); |
35
|
|
|
|
|
|
|
|
36
|
0
|
0
|
0
|
|
|
|
return (wantarray && ref $ret eq 'ARRAY') ? @$ret : $ret; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub exists { |
40
|
0
|
|
|
0
|
1
|
|
my ($self, $redis) = @_; |
41
|
0
|
|
|
|
|
|
return $redis->script_exists($self->sha1)->[0]; |
42
|
|
|
|
|
|
|
} |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub load { |
45
|
0
|
|
|
0
|
1
|
|
my ($self, $redis) = @_; |
46
|
0
|
|
|
|
|
|
my $sha = $self->sha1; |
47
|
0
|
|
|
|
|
|
my $redis_sha = $redis->script_load($self->{script}); |
48
|
0
|
0
|
|
|
|
|
if (lc $sha ne lc $redis_sha) { |
49
|
0
|
|
|
|
|
|
die "SHA is unmatch (expected $sha but redis returns $redis_sha)"; |
50
|
|
|
|
|
|
|
} |
51
|
0
|
|
|
|
|
|
return $sha; |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
sub sha1 { |
55
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
56
|
0
|
|
0
|
|
|
|
return $self->{sha} ||= sha1_hex($self->{script}); |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub redis_eval { |
60
|
0
|
|
|
0
|
0
|
|
my ($redis, $script, $keys, $args) = @_; |
61
|
0
|
|
|
|
|
|
return __PACKAGE__->new(script => $script)->eval($redis, $keys, $args); |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
1; |
65
|
|
|
|
|
|
|
__END__ |