File Coverage

blib/lib/Net/Async/Redis/Protocol.pm
Criterion Covered Total %
statement 69 117 58.9
branch 51 108 47.2
condition 14 27 51.8
subroutine 10 14 71.4
pod 3 8 37.5
total 147 274 53.6


line stmt bran cond sub pod time code
1             package Net::Async::Redis::Protocol;
2              
3 1     1   142849 use strict;
  1         13  
  1         30  
4 1     1   5 use warnings;
  1         2  
  1         45  
5              
6             our $VERSION = '4.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         2  
  1         54  
19 1     1   548 use Log::Any qw($log);
  1         9097  
  1         5  
20 1     1   2214 use List::Util qw(min);
  1         2  
  1         73  
21              
22             # Normal string interpolation
23 1     1   7 use constant CRLF => "\x0D\x0A";
  1         1  
  1         1702  
24              
25             # Regex usage
26             my $CRLF = CRLF;
27              
28 4     4 0 23360 sub new { bless { protocol => 'resp3', hashrefs => 0, @_[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 9049     9049 1 37333 my ($self, $data) = @_;
42 9049 50       17507 die 'blessed data is not ok' if blessed $data;
43 9049 100       17475 if(my $type = reftype $data) {
44 2014 50       3310 if($type eq 'ARRAY') {
    0          
45 2014         5865 return '*' . (0 + @$data) . CRLF . join '', map $self->encode($_), @$data
46             } elsif($type eq 'HASH') {
47 0         0 return '%' . (0 + keys %$data) . CRLF . join '', map $self->encode($_), map { $_ => $data->{$_} } sort keys %$data
  0         0  
48             }
49 0         0 die 'no support for ' . $type
50             }
51 7035 100 66     40774 if(!defined($data)) {
    100 66        
    100 33        
    50 66        
    100          
52 5 100       24 return $self->{protocol} eq 'resp3' ? '_' . CRLF : '$-1' . CRLF;
53             } elsif(!length($data)) {
54 4         22 return '$0' . CRLF . CRLF;
55             } elsif(($data ^ $data) eq "0" and int(0+$data) eq $data and $data !~ /inf/i) {
56 1014         3030 return ':' . (0 + $data) . CRLF;
57             } elsif(($data ^ $data) eq "0" and 0+$data eq $data) {
58 0         0 return ',' . lc(0 + $data) . CRLF;
59             } elsif(length($data) < 100 and $data !~ /[$CRLF]/) {
60 6010         21234 return '+' . $data . CRLF;
61             }
62 2         13 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 32     32 1 1704 my ($self, $bytes) = @_;
92              
93 32         61 my $len = $self->{parsing_bulk};
94             ITEM:
95 32         72 for ($$bytes) {
96 9055 50       20538 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 9055 100       65183 if(defined($len)) {
101 6 50       19 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         26 $self->item(substr $_, 0, delete $self->{parsing_bulk}, '');
104 6         3626 undef $len;
105 6 50       26 last ITEM unless length;
106             }
107 9049 100 66     2037751 if(s{^\+([^\x0D]*)$CRLF}{}) {
    100 100        
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
108 6010         16677 $self->item("$1");
109             } elsif(s{^:([^\x0D]*)$CRLF}{}) {
110 1014         2368 my $int = $1;
111 1014 50 33     5098 die 'invalid integer value ' . $int unless looks_like_number($int) && int($int) eq $int;
112 1014         2363 $self->item(0 + $int);
113             } elsif(s{^,([^\x0D]*)$CRLF}{}) {
114 0         0 my $num = $1;
115 0 0 0     0 die 'invalid numeric value ' . $num unless looks_like_number($num) && lc(0 + $num) eq lc($num);
116 0         0 $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         19 $len = $1;
121 6 50       20 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         16 $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 2014         6317 my $pending = $1;
138 2014 50       6565 die 'invalid numeric value for array ' . $pending unless 0+$pending eq $pending;
139 2014 100       3426 if($pending) {
140 2012         2752 push @{$self->{active}}, { type => 'array', pending => $pending };
  2012         8841  
141             } else {
142 2         5 $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 0         0 my $pending = $1;
154 0 0       0 die 'invalid numeric value for map ' . $pending unless 0+$pending eq $pending;
155 0 0       0 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 0         0 push @{$self->{active}}, { type => 'map', pending => 2 * $pending };
  0         0  
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 9049 100       2115250 redo ITEM if length;
178             }
179             }
180              
181 0     0 0 0 sub parse { $_[0]->decode($_[1]) }
182              
183             sub item {
184 7037     7037 0 11570 my ($self, $data) = @_;
185 7037 50 33     14359 $data = [ %$data ] if ref $data eq 'HASH' and not $self->{hashrefs};
186 7037         10306 while(1) {
187 9049 100       11212 return $self->{handler}->($data) unless @{$self->{active} || []};
  9049 100       22660  
188              
189 9017         13244 push @{$self->{active}[-1]{items}}, $data;
  9017         22183  
190 9017 100       21724 return if --$self->{active}[-1]{pending};
191 2012         2503 my $active = pop @{$self->{active}};
  2012         3114  
192             $data = $active->{type} eq 'map'
193             ? ($self->{hashrefs}
194 0         0 ? { @{$active->{items}} }
195 0         0 : [ @{$active->{items}} ]
196             )
197 2012 0       4116 : $active->{items};
    50          
198              
199             # Skip attributes entirely for now
200 2012 50       3868 return if $active->{type} eq 'attribute';
201 2012 50       4659 return $self->item_pubsub($data) if $active->{type} eq 'push';
202             }
203             }
204              
205             sub item_error {
206 0     0 0   my ($self, $err) = @_;
207 0 0         $self->{error}->($err) if $self->{error};
208 0           $self
209             }
210              
211             sub item_pubsub {
212 0     0 0   my ($self, $item) = @_;
213 0 0         $self->{pubsub}->(@$item) if $self->{pubsub};
214 0           $self
215             }
216              
217             1;
218              
219             __END__