line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Protocol::Redis::Faster; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
58802
|
use strict; |
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
27
|
|
4
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
22
|
|
5
|
1
|
|
|
1
|
|
4
|
use Carp (); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
25
|
|
6
|
|
|
|
|
|
|
|
7
|
1
|
|
|
1
|
|
388
|
use parent 'Protocol::Redis'; |
|
1
|
|
|
|
|
258
|
|
|
1
|
|
|
|
|
4
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our $VERSION = '0.002'; |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
my %simple_types = ('+' => 1, '-' => 1, ':' => 1); |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
sub encode { |
14
|
10
|
|
|
10
|
1
|
25
|
my $self = shift; |
15
|
|
|
|
|
|
|
|
16
|
10
|
|
|
|
|
15
|
my $encoded = ''; |
17
|
10
|
|
|
|
|
21
|
while (@_) { |
18
|
16
|
|
|
|
|
22
|
my $message = shift; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
# Order optimized for client encoding; |
21
|
|
|
|
|
|
|
# client commands are sent as arrays of bulk strings |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# Bulk strings |
24
|
16
|
100
|
|
|
|
39
|
if ($message->{type} eq '$') { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
25
|
8
|
100
|
|
|
|
16
|
if (defined $message->{data}) { |
26
|
6
|
|
|
|
|
18
|
$encoded .= '$' . length($message->{data}) . "\r\n" . $message->{data} . "\r\n"; |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
else { |
29
|
2
|
|
|
|
|
4
|
$encoded .= '$-1' . "\r\n"; |
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
# Arrays |
34
|
|
|
|
|
|
|
elsif ($message->{type} eq '*') { |
35
|
5
|
100
|
|
|
|
11
|
if (defined $message->{data}) { |
36
|
4
|
|
|
|
|
6
|
$encoded .= '*' . scalar(@{$message->{data}}) . "\r\n"; |
|
4
|
|
|
|
|
9
|
|
37
|
4
|
|
|
|
|
6
|
unshift @_, @{$message->{data}}; |
|
4
|
|
|
|
|
11
|
|
38
|
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
|
else { |
40
|
1
|
|
|
|
|
2
|
$encoded .= '*-1' . "\r\n"; |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
} |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
# Simple strings, errors, and integers |
45
|
|
|
|
|
|
|
elsif (exists $simple_types{$message->{type}}) { |
46
|
3
|
|
|
|
|
10
|
$encoded .= $message->{type} . $message->{data} . "\r\n"; |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
# Invalid type |
50
|
|
|
|
|
|
|
else { |
51
|
0
|
|
|
|
|
0
|
Carp::croak(qq/Unknown message type $message->{type}/); |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
10
|
|
|
|
|
36
|
return $encoded; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
26
|
|
|
26
|
1
|
43
|
sub get_message { shift @{$_[0]{_messages}} } |
|
26
|
|
|
|
|
173
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub on_message { |
61
|
9
|
|
|
9
|
1
|
6983
|
my ($self, $cb) = @_; |
62
|
9
|
|
|
|
|
25
|
$self->{_on_message_cb} = $cb; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub parse { |
66
|
33
|
|
|
33
|
1
|
2267
|
my ($self, $input) = @_; |
67
|
33
|
|
|
|
|
53
|
$self->{_buf} .= $input; |
68
|
|
|
|
|
|
|
|
69
|
33
|
|
|
|
|
48
|
my $buf = \$self->{_buf}; |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
CHUNK: |
72
|
33
|
|
|
|
|
75
|
while (length $$buf) { |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# Look for message type and get the actual data, |
75
|
|
|
|
|
|
|
# length of the bulk string or the size of the array |
76
|
49
|
100
|
|
|
|
99
|
if (!$self->{_curr}{type}) { |
77
|
48
|
|
|
|
|
72
|
my $pos = index $$buf, "\r\n"; |
78
|
48
|
100
|
|
|
|
82
|
return if $pos < 0; # Wait for more data |
79
|
|
|
|
|
|
|
|
80
|
43
|
|
|
|
|
89
|
$self->{_curr}{type} = substr $$buf, 0, 1; |
81
|
43
|
|
|
|
|
74
|
$self->{_curr}{len} = substr $$buf, 1, $pos - 1; |
82
|
43
|
|
|
|
|
70
|
substr $$buf, 0, $pos + 2, ''; # Remove type + length/data + \r\n |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
# Order optimized for client decoding; |
86
|
|
|
|
|
|
|
# large array replies usually contain bulk strings |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
# Bulk strings |
89
|
44
|
100
|
|
|
|
100
|
if ($self->{_curr}{type} eq '$') { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
90
|
20
|
100
|
|
|
|
52
|
if ($self->{_curr}{len} == -1) { |
|
|
100
|
|
|
|
|
|
91
|
1
|
|
|
|
|
2
|
$self->{_curr}{data} = undef; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
elsif (length($$buf) - 2 < $self->{_curr}{len}) { |
94
|
1
|
|
|
|
|
2
|
return; # Wait for more data |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
else { |
97
|
18
|
|
|
|
|
31
|
$self->{_curr}{data} = substr $$buf, 0, $self->{_curr}{len}, ''; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
19
|
|
|
|
|
29
|
substr $$buf, 0, 2, ''; # Remove \r\n |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
# Simple strings, errors, and integers |
104
|
|
|
|
|
|
|
elsif (exists $simple_types{$self->{_curr}{type}}) { |
105
|
16
|
|
|
|
|
31
|
$self->{_curr}{data} = delete $self->{_curr}{len}; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# Arrays |
109
|
|
|
|
|
|
|
elsif ($self->{_curr}{type} eq '*') { |
110
|
8
|
100
|
|
|
|
22
|
$self->{_curr}{data} = $self->{_curr}{len} < 0 ? undef : []; |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# Fill the array with data |
113
|
8
|
100
|
|
|
|
25
|
if ($self->{_curr}{len} > 0) { |
114
|
6
|
|
|
|
|
21
|
$self->{_curr} = {parent => $self->{_curr}}; |
115
|
6
|
|
|
|
|
15
|
next CHUNK; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
# Invalid input |
120
|
|
|
|
|
|
|
else { |
121
|
0
|
|
|
|
|
0
|
Carp::croak(qq/Unexpected input "$self->{_curr}{type}"/); |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
# Fill parent array with data |
125
|
37
|
|
|
|
|
77
|
while (my $parent = delete $self->{_curr}{parent}) { |
126
|
10
|
|
|
|
|
15
|
delete $self->{_curr}{len}; |
127
|
10
|
|
|
|
|
11
|
push @{$parent->{data}}, $self->{_curr}; |
|
10
|
|
|
|
|
19
|
|
128
|
|
|
|
|
|
|
|
129
|
10
|
100
|
|
|
|
10
|
if (@{$parent->{data}} < $parent->{len}) { |
|
10
|
|
|
|
|
18
|
|
130
|
4
|
|
|
|
|
6
|
$self->{_curr} = {parent => $parent}; |
131
|
4
|
|
|
|
|
10
|
next CHUNK; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
else { |
134
|
6
|
|
|
|
|
15
|
$self->{_curr} = $parent; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
# Emit a complete message |
139
|
33
|
|
|
|
|
51
|
delete $self->{_curr}{len}; |
140
|
33
|
100
|
|
|
|
46
|
if (defined $self->{_on_message_cb}) { |
141
|
8
|
|
|
|
|
17
|
$self->{_on_message_cb}->($self, delete $self->{_curr}); |
142
|
|
|
|
|
|
|
} else { |
143
|
25
|
|
|
|
|
28
|
push @{$self->{_messages}}, delete $self->{_curr}; |
|
25
|
|
|
|
|
76
|
|
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
1; |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
=head1 NAME |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
Protocol::Redis::Faster - Optimized pure-perl Redis protocol parser/encoder |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
=head1 SYNOPSIS |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
use Protocol::Redis::Faster; |
157
|
|
|
|
|
|
|
my $redis = Protocol::Redis::Faster->new(api => 1) or die "API v1 not supported"; |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
$redis->parse("+foo\r\n"); |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# get parsed message |
162
|
|
|
|
|
|
|
my $message = $redis->get_message; |
163
|
|
|
|
|
|
|
print "parsed message: ", $message->{data}, "\n"; |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# asynchronous parsing interface |
166
|
|
|
|
|
|
|
$redis->on_message(sub { |
167
|
|
|
|
|
|
|
my ($redis, $message) = @_; |
168
|
|
|
|
|
|
|
print "parsed message: ", $message->{data}, "\n"; |
169
|
|
|
|
|
|
|
}); |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
# parse pipelined message |
172
|
|
|
|
|
|
|
$redis->parse("+bar\r\n-error\r\n"); |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# create message |
175
|
|
|
|
|
|
|
print "Get key message:\n", |
176
|
|
|
|
|
|
|
$redis->encode({type => '*', data => [ |
177
|
|
|
|
|
|
|
{type => '$', data => 'string'}, |
178
|
|
|
|
|
|
|
{type => '+', data => 'OK'} |
179
|
|
|
|
|
|
|
]}); |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=head1 DESCRIPTION |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
This module implements the L API with more optimized pure-perl |
184
|
|
|
|
|
|
|
internals. See L for usage documentation. |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
This is a low level parsing module, if you are looking to use Redis in Perl, |
187
|
|
|
|
|
|
|
try L, L, or L. |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
=head1 BUGS |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
Report any issues on the public bugtracker. |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
=head1 AUTHORS |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
Dan Book |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
Jan Henning Thorsen |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
=head1 CREDITS |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
Thanks to Sergey Zasenko for the original L |
202
|
|
|
|
|
|
|
and defining the API. |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
This software is Copyright (c) 2019 by Dan Book, Jan Henning Thorsen. |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
This is free software, licensed under: |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
The Artistic License 2.0 (GPL Compatible) |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=head1 SEE ALSO |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
L |