File Coverage

blib/lib/Net/Async/Redis/Protocol.pm
Criterion Covered Total %
statement 79 114 69.3
branch 60 102 58.8
condition 17 24 70.8
subroutine 10 14 71.4
pod 3 8 37.5
total 169 262 64.5


line stmt bran cond sub pod time code
1             package Net::Async::Redis::Protocol;
2              
3 1     1   98736 use strict;
  1         11  
  1         29  
4 1     1   5 use warnings;
  1         1  
  1         43  
5              
6             our $VERSION = '3.000'; # VERSION
7              
8             =head1 NAME
9              
10             Net::Async::Redis::Protocol - simple implementation of the Redis wire protocol
11              
12             =head1 DESCRIPTION
13              
14             Used internally by L and L.
15              
16             =cut
17              
18 1     1   5 use Scalar::Util qw(blessed reftype looks_like_number);
  1         9  
  1         50  
19 1     1   498 use Log::Any qw($log);
  1         8582  
  1         5  
20 1     1   2212 use List::Util qw(min);
  1         2  
  1         132  
21              
22             # Normal string interpolation
23 1     1   7 use constant CRLF => "\x0D\x0A";
  1         2  
  1         1596  
24              
25             # Regex usage
26             my $CRLF = CRLF;
27              
28 4     4 0 8151 sub new { bless { protocol => 'resp3', @_[1..$#_] }, $_[0] }
29              
30             =head2 encode
31              
32             Given a Perl data structure, will return data suitable for sending
33             back as a response as from a Redis server.
34              
35             Note that this is not the correct format for client requests,
36             see L instead.
37              
38             =cut
39              
40             sub encode {
41 55     55 1 20612 my ($self, $data) = @_;
42 55 50       171 die 'blessed data is not ok' if blessed $data;
43 55 100       131 if(my $type = reftype $data) {
44 13 100       36 if($type eq 'ARRAY') {
    50          
45 12         66 return '*' . (0 + @$data) . CRLF . join '', map $self->encode($_), @$data
46             } elsif($type eq 'HASH') {
47 1         8 return '%' . (0 + keys %$data) . CRLF . join '', map $self->encode($_), map { $_ => $data->{$_} } sort keys %$data
  2         7  
48             }
49 0         0 die 'no support for ' . $type
50             }
51 42 100 100     368 if(!defined($data)) {
    100 100        
    100 66        
    100 66        
    100          
52 5 100       22 return $self->{protocol} eq 'resp3' ? '_' . CRLF : '$-1' . CRLF;
53             } elsif(!length($data)) {
54 4         19 return '$0' . CRLF . CRLF;
55             } elsif(($data ^ $data) eq "0" and int(0+$data) eq $data and $data !~ /inf/i) {
56 16         79 return ':' . (0 + $data) . CRLF;
57             } elsif(($data ^ $data) eq "0" and 0+$data eq $data) {
58 3         14 return ',' . lc(0 + $data) . CRLF;
59             } elsif(length($data) < 100 and $data !~ /[$CRLF]/) {
60 12         56 return '+' . $data . CRLF;
61             }
62 2         11 return '$' . length($data) . CRLF . $data . CRLF;
63             }
64              
65             =head2 encode_from_client
66              
67             Handles client format encoding. Expects a list of data items, and will
68             convert them into length-prefixed bulk strings as a single response item.
69              
70             =cut
71              
72             sub encode_from_client {
73 0     0 1 0 my ($self, @data) = @_;
74             return '*' . (0 + @data) . CRLF . join '', map {
75 0         0 '$' . length($_) . CRLF . $_ . CRLF
  0         0  
76             } @data;
77             }
78              
79             =head2 decode
80              
81             Decodes wire protocol data into Perl data structures.
82              
83             Expects to be called with a reference to a byte string, and will
84             extract as much as it can from that string (destructively).
85              
86             Likely to call L or L zero or more times.
87              
88             =cut
89              
90             sub decode {
91 35     35 1 1560 my ($self, $bytes) = @_;
92              
93 35         60 my $len = $self->{parsing_bulk};
94             ITEM:
95 35         72 for ($$bytes) {
96 61 50       167 if($log->is_trace) {
97 0         0 my $bytes = substr $_, 0, min(16, length($_));
98 0         0 $log->tracef('Next few bytes: %s (%v02x)', $bytes, $bytes);
99             }
100 61 100       535 if(defined($len)) {
101 6 50       15 last ITEM unless length($_) >= $len + 2;
102 6 50       18 die 'invalid bulk data, did not end in CRLF' unless substr($_, $len, 2, '') eq CRLF;
103 6         24 $self->item(substr $_, 0, delete $self->{parsing_bulk}, '');
104 6         3308 undef $len;
105 6 50       26 last ITEM unless length;
106             }
107 55 100 66     920 if(s{^\+([^\x0D]*)$CRLF}{}) {
    100 100        
    100          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    0          
    0          
    0          
108 12         49 $self->item("$1");
109             } elsif(s{^:([^\x0D]*)$CRLF}{}) {
110 16         38 my $int = $1;
111 16 50 33     144 die 'invalid integer value ' . $int unless looks_like_number($int) && int($int) eq $int;
112 16         41 $self->item(0 + $int);
113             } elsif(s{^,([^\x0D]*)$CRLF}{}) {
114 3         10 my $num = $1;
115 3 50 33     36 die 'invalid numeric value ' . $num unless looks_like_number($num) && lc(0 + $num) eq lc($num);
116 3         9 $self->item(0 + $num);
117             } elsif(s{^#([tf])$CRLF}{}) {
118 0         0 $self->item($1 eq 't');
119             } elsif(s{^\$([0-9]+)$CRLF}{}) {
120 6         38 $len = $1;
121 6 50       21 die 'invalid numeric value for length ' . $len unless 0+$len eq $len;
122 6         15 $self->{parsing_bulk} = $len;
123             } elsif(s{^=([0-9]+)$CRLF}{}) {
124 0         0 $len = $1;
125 0 0       0 die 'invalid numeric value for length ' . $len unless 0+$len eq $len;
126 0         0 $self->{parsing_bulk} = $len;
127             } elsif(s{^\$-1$CRLF}{} or s{^\*-1$CRLF}{} or s{^_$CRLF}{}) {
128 5         15 $self->item(undef);
129             } elsif(s{^>([0-9]+)$CRLF}{}) {
130 0         0 my $pending = $1;
131 0 0       0 die 'invalid numeric value for push ' . $pending unless 0+$pending eq $pending;
132 0 0       0 push @{$self->{active}}, {
  0         0  
133             type => 'push',
134             pending => $pending
135             } if $pending;
136             } elsif(s{^\*([0-9]+)$CRLF}{}) {
137 12         36 my $pending = $1;
138 12 50       38 die 'invalid numeric value for array ' . $pending unless 0+$pending eq $pending;
139 12 100       25 if($pending) {
140 10         16 push @{$self->{active}}, { type => 'array', pending => $pending };
  10         41  
141             } else {
142 2         6 $self->item([ ]);
143             }
144             } elsif(s{^~([0-9]+)$CRLF}{}) {
145 0         0 my $pending = $1;
146 0 0       0 die 'invalid numeric value for set ' . $pending unless 0+$pending eq $pending;
147 0 0       0 if($pending) {
148 0         0 push @{$self->{active}}, { type => 'set', pending => $pending };
  0         0  
149             } else {
150 0         0 $self->item([ ]);
151             }
152             } elsif(s{^%([0-9]+)$CRLF}{}) {
153 1         4 my $pending = $1;
154 1 50       19 die 'invalid numeric value for map ' . $pending unless 0+$pending eq $pending;
155 1 50       4 if($pending) {
156             # We provide 2x the count here, for key/value pairs, and expect
157             # the handler to convert to a hash once it's received sufficient
158             # items to emit the full element
159 1         3 push @{$self->{active}}, { type => 'map', pending => 2 * $pending };
  1         6  
160             } else {
161 0         0 $self->item({ });
162             }
163             } elsif(s{^\|([0-9]+)$CRLF}{}) {
164 0         0 my $pending = $1;
165 0 0       0 die 'invalid numeric value for attribute ' . $pending unless 0+$pending eq $pending;
166 0 0       0 push @{$self->{active}}, {
  0         0  
167             type => 'attribute',
168             pending => 2 * $pending
169             } if $pending;
170             } elsif(s{^-([^\x0D]*)$CRLF}{}) {
171 0         0 $self->item_error($1);
172             } elsif(s{^!([^\x0D]*)$CRLF}{}) {
173 0         0 die 'cannot handle blob error yet';
174             } else {
175 0         0 last ITEM;
176             }
177 55 100       30045 redo ITEM if length;
178             }
179             }
180              
181 0     0 0 0 sub parse { $_[0]->decode($_[1]) }
182              
183             sub item {
184 44     44 0 89 my ($self, $data) = @_;
185 44         60 while(1) {
186 55 100       82 return $self->{handler}->($data) unless @{$self->{active} || []};
  55 100       231  
187              
188 20         27 push @{$self->{active}[-1]{items}}, $data;
  20         57  
189 20 100       52 return if --$self->{active}[-1]{pending};
190 11         14 my $active = pop @{$self->{active}};
  11         20  
191 11 100       27 $data = $active->{type} eq 'map' ? { @{$active->{items}} } : $active->{items};
  1         4  
192              
193             # Skip attributes entirely for now
194 11 50       36 return if $active->{type} eq 'attribute';
195             }
196             }
197              
198             sub item_error {
199 0     0 0   my ($self, $err) = @_;
200 0 0         $self->{error}->($err) if $self->{error};
201 0           $self
202             }
203              
204             sub item_pubsub {
205 0     0 0   my ($self, $item) = @_;
206 0 0         $self->{pubsub}->($item) if $self->{pubsub};
207 0           $self
208             }
209              
210             1;
211              
212             __END__