File Coverage

blib/lib/AnyEvent/Redis/Protocol.pm
Criterion Covered Total %
statement 6 69 8.7
branch 0 40 0.0
condition 0 12 0.0
subroutine 2 4 50.0
pod 0 1 0.0
total 8 126 6.3


line stmt bran cond sub pod time code
1             package AnyEvent::Redis::Protocol;
2              
3 8     8   44 use strict;
  8         16  
  8         341  
4 8     8   46 use warnings;
  8         15  
  8         7900  
5              
6             =head1 NAME
7              
8             AnyEvent::Redis::Protocol - Redis response parser (read handler) for AnyEvent
9              
10             =head1 DESCRIPTION
11              
12             This package should not be directly used. It provides an AnyEvent read handler
13             capable of parsing Redis responses.
14              
15             =head1 SEE ALSO
16              
17             L,
18             Redis Protocol Specification L
19              
20             =cut
21              
22             sub anyevent_read_type {
23 0     0 0   my ($handle, $cb) = @_;
24              
25             return sub {
26             $handle->push_read(line => sub {
27 0           my $line = $_[1];
28 0           my $type = substr($line, 0, 1);
29 0           my $value = substr($line, 1);
30 0 0 0       if ($type eq '*') {
    0          
    0          
    0          
31             # Multi-bulk reply
32 0           my $remaining = $value;
33 0 0         if ($remaining == 0) {
    0          
34 0           $cb->([]);
35             } elsif ($remaining == -1) {
36 0           $cb->(undef);
37             } else {
38 0           my $results = [];
39             $handle->unshift_read(sub {
40 0           my $need_more_data = 0;
41 0           do {
42 0 0         if ($handle->{rbuf} =~ /^(\$(-?\d+)\015\012)/) {
    0          
    0          
43 0           my ($match, $vallen) = ($1, $2);
44 0 0         if ($vallen == -1) {
    0          
45             # Delete the bulk header.
46 0           substr($handle->{rbuf}, 0, length($match), '');
47 0           push @$results, undef;
48 0 0         unless (--$remaining) {
49 0           $cb->($results);
50 0           return 1;
51             }
52             } elsif (length $handle->{rbuf} >= (length($match) + $vallen + 2)) {
53             # OK, we have enough in our buffer.
54             # Delete the bulk header.
55 0           substr($handle->{rbuf}, 0, length($match), '');
56 0           my $value = substr($handle->{rbuf}, 0, $vallen, '');
57 0 0 0       $value = $handle->{encoding}->decode($value)
58             if $handle->{encoding} && $vallen;
59 0           push @$results, $value;
60             # Delete trailing data characters.
61 0           substr($handle->{rbuf}, 0, 2, '');
62 0 0         unless (--$remaining) {
63 0           $cb->($results);
64 0           return 1;
65             }
66             } else {
67 0           $need_more_data = 1;
68             }
69             } elsif ($handle->{rbuf} =~ s/^([\+\-:])([^\015\012]*)\015\012//) {
70 0           my ($type, $value) = ($1, $2);
71 0 0 0       if ($type eq '+' || $type eq ':') {
    0          
72 0           push @$results, $value;
73             } elsif ($type eq '-') {
74             # Embedded error; this seems possible only in EXEC answer,
75             # so include error in results; don't abort parsing
76 0           push @$results, bless \$value, 'AnyEvent::Redis::Error';
77             }
78 0 0         unless (--$remaining) {
79 0           $cb->($results);
80 0           return 1;
81             }
82             } elsif (substr($handle->{rbuf}, 0, 1) eq '*') {
83             # Oh, how fun! A nested bulk reply.
84 0           my $reader; $reader = sub {
85             $handle->unshift_read("AnyEvent::Redis::Protocol" => sub {
86 0           push @$results, $_[0];
87 0 0         if (--$remaining) {
88 0           $reader->();
89             } else {
90 0           undef $reader;
91 0           $cb->($results);
92             }
93 0           });
94 0           };
95 0           $reader->();
96 0           return 1;
97             } else {
98             # Nothing matched - read more...
99 0           $need_more_data = 1;
100             }
101             } until $need_more_data;
102 0           return; # get more data
103 0           });
104             }
105             } elsif ($type eq '+' || $type eq ':') {
106             # Single line/integer reply
107 0           $cb->($value);
108             } elsif ($type eq '-') {
109             # Single-line error reply
110 0           $cb->($value, 1);
111             } elsif ($type eq '$') {
112             # Bulk reply
113 0           my $length = $value;
114 0 0         if ($length == -1) {
115 0           $cb->(undef);
116             } else {
117             # We need to read 2 bytes more than the length (stupid
118             # CRLF framing). Then we need to discard them.
119             $handle->unshift_read(chunk => $length + 2, sub {
120 0           my $data = $_[1];
121 0           my $value = substr($data, 0, $length);
122 0 0 0       $value = $handle->{encoding}->decode($value)
123             if $handle->{encoding} && $length;
124 0           $cb->($value);
125 0           });
126             }
127             }
128 0           return 1;
129 0     0     });
130 0           return 1;
131 0           };
132             }
133              
134             =head1 AUTHOR
135              
136             Michael S. Fischer
137              
138             =head1 COPYRIGHT AND LICENSE
139              
140             Copyright (C) 2010 Michael S. Fischer.
141              
142             This program is free software; you can redistribute it and/or modify it
143             under the terms of either: the GNU General Public License as published
144             by the Free Software Foundation; or the Artistic License.
145              
146             See http://dev.perl.org/licenses/ for more information.
147              
148             =cut
149              
150             1;
151              
152             __END__