File Coverage

blib/lib/JSON/RPC2/Client.pm
Criterion Covered Total %
statement 123 124 99.1
branch 73 74 98.6
condition 34 37 91.8
subroutine 19 19 100.0
pod 11 11 100.0
total 260 265 98.1


line stmt bran cond sub pod time code
1             package JSON::RPC2::Client;
2 15     15   1891166 use 5.010001;
  15         84  
3 15     15   88 use warnings;
  15         118  
  15         909  
4 15     15   134 use strict;
  15         30  
  15         493  
5 15     15   6704 use utf8;
  15         4022  
  15         134  
6 15     15   599 use Carp;
  15         32  
  15         1616  
7              
8             our $VERSION = 'v2.2.0';
9              
10 15     15   543 use JSON::MaybeXS;
  15         11780  
  15         999  
11 15     15   85 use Scalar::Util qw( weaken refaddr );
  15         31  
  15         29347  
12              
13              
14             sub new {
15 13     13 1 1947700 my ($class) = @_;
16 13         117 my $self = {
17             next_id => 0,
18             free_id => [],
19             call => {},
20             id => {},
21             lax_response_version => 0,
22             };
23 13         56 return bless $self, $class;
24             }
25              
26             sub lax_response_version {
27 3     3 1 956 my ($self, $lax_response_version) = @_;
28 3 100       12 $self->{lax_response_version} = int($lax_response_version) if defined $lax_response_version;
29             return $self->{lax_response_version}
30 3         20 }
31              
32             sub batch {
33 11     11 1 2425 my ($self, @requests) = @_;
34 11         28 my @call = grep {ref} @requests;
  45         90  
35 11         24 @requests = grep {!ref} @requests;
  45         90  
36 11 100       82 croak 'at least one request required' if !@requests;
37 9         39 my $request = '['.join(q{,}, @requests).']';
38 9         42 return ($request, @call);
39             }
40              
41             sub notify {
42 11     11 1 25359 my ($self, $method, @params) = @_;
43 11 100       66 croak 'method required' if !defined $method;
44 10 100       163 return encode_json({
45             jsonrpc => '2.0',
46             method => $method,
47             (!@params ? () : (
48             params => \@params,
49             )),
50             });
51             }
52              
53             sub notify_named {
54 13     13 1 9259 my ($self, $method, @params) = @_;
55 13 100       67 croak 'method required' if !defined $method;
56 12 100       64 croak 'odd number of elements in %params' if @params % 2;
57 10         47 my %params = @params;
58 10 100       163 return encode_json({
59             jsonrpc => '2.0',
60             method => $method,
61             (!@params ? () : (
62             params => \%params,
63             )),
64             });
65             }
66              
67             sub call {
68 44     44 1 48854 my ($self, $method, @params) = @_;
69 44 100       189 croak 'method required' if !defined $method;
70 42         212 my ($id, $call) = $self->_get_id();
71 42 100       591 my $request = encode_json({
72             jsonrpc => '2.0',
73             method => $method,
74             (!@params ? () : (
75             params => \@params,
76             )),
77             id => $id,
78             });
79 42 100       438 return wantarray ? ($request, $call) : $request;
80             }
81              
82             sub call_named {
83 28     28 1 41653 my ($self, $method, @params) = @_;
84 28 100       133 croak 'method required' if !defined $method;
85 26 100       142 croak 'odd number of elements in %params' if @params % 2;
86 24         103 my %params = @params;
87 24         108 my ($id, $call) = $self->_get_id();
88 24 100       346 my $request = encode_json({
89             jsonrpc => '2.0',
90             method => $method,
91             (!@params ? () : (
92             params => \%params,
93             )),
94             id => $id,
95             });
96 24 100       193 return wantarray ? ($request, $call) : $request;
97             }
98              
99             sub _get_id {
100 66     66   131 my $self = shift;
101 66 100       117 my $id = @{$self->{free_id}} ? pop @{$self->{free_id}} : $self->{next_id}++;
  66         273  
  12         36  
102 66         126 my $call = {};
103 66         247 $self->{call}{ refaddr($call) } = $call;
104 66         204 $self->{id}{ $id } = $call;
105 66         177 weaken($self->{id}{ $id });
106 66         253 return ($id, $call);
107             }
108              
109             sub pending {
110 6     6 1 34 my ($self) = @_;
111 6         6 return values %{ $self->{call} };
  6         49  
112             }
113              
114             sub cancel {
115 13     13 1 10540 my ($self, $call) = @_;
116 13 100       104 croak 'no such request' if !delete $self->{call}{ refaddr($call) };
117 9         26 return;
118             }
119              
120             sub batch_response {
121 18     18 1 14134 my ($self, $json) = @_;
122 18 100       78 croak 'require 1 param' if @_ != 2;
123              
124 16         27 undef $@;
125 16 100       35 my $response = ref $json ? $json : eval { JSON::MaybeXS->new(allow_nonref=>0)->decode($json) };
  15         72  
126 16 100       399 if ($@) {
127 7         30 return [ 'Parse error' ];
128             }
129 9 100 66     45 if ($response && ref $response eq 'HASH') {
130 4         14 return [ $self->response($response) ];
131             }
132 5 50 33     21 if (!$response || ref $response ne 'ARRAY') {
133 0         0 return [ 'expect Array or Object' ];
134             }
135 5 100       8 if (!@{$response}) {
  5         11  
136 1         5 return [ 'empty Array' ];
137             }
138              
139 4         8 return map {[ $self->response($_) ]} @{$response};
  5         14  
  4         8  
140             }
141              
142             sub response { ## no critic (ProhibitExcessComplexity RequireArgUnpacking)
143 82     82 1 55435 my ($self, $json) = @_;
144 82 100       348 croak 'require 1 param' if @_ != 2;
145              
146 80         157 undef $@;
147 80 100       229 my $response = ref $json ? $json : eval { JSON::MaybeXS->new(allow_nonref=>0)->decode($json) };
  67         372  
148 80 100       2075 if ($@) {
149 7         33 return 'Parse error';
150             }
151 73 100       255 if (ref $response ne 'HASH') {
152 1         5 return 'expect Object';
153             }
154 72 100 100     531 if (!$self->{lax_response_version} && (!defined $response->{jsonrpc} || $response->{jsonrpc} ne '2.0')) {
      100        
155 12         65 return 'expect {jsonrpc}="2.0"';
156             }
157 60 100 100     345 if (!exists $response->{id} || ref $response->{id} || !defined $response->{id}) {
      100        
158 10         55 return 'expect {id} is scalar';
159             }
160 50 100       212 if (!exists $self->{id}{ $response->{id} }) {
161 4         26 return 'unknown {id}';
162             }
163 46 100 100     223 if (!(exists $response->{result} xor exists $response->{error})) {
164 2         14 return 'expect {result} or {error}';
165             }
166 44 100       126 if (exists $response->{error}) {
167 26         47 my $e = $response->{error};
168 26 100       104 if (ref $e ne 'HASH') {
169 6         41 return 'expect {error} is Object';
170             }
171 20 100 100     175 if (!defined $e->{code} || ref $e->{code} || $e->{code} !~ /\A-?\d+\z/xms) {
      100        
172 8         57 return 'expect {error}{code} is Integer';
173             }
174 12 100 100     59 if (!defined $e->{message} || ref $e->{message}) {
175 6         46 return 'expect {error}{message} is String';
176             }
177             ## no critic (ProhibitMagicNumbers)
178 6 100 100     11 if ((3 == keys %{$e} && !exists $e->{data}) || 3 < keys %{$e}) {
  6   100     54  
  5         22  
179 2         16 return 'only optional key must be {error}{data}';
180             }
181             }
182              
183 22         42 my $id = $response->{id};
184 22         61 push @{ $self->{free_id} }, $id;
  22         86  
185 22         49 my $call = delete $self->{id}{ $id };
186 22 100       65 if ($call) {
187 20         67 $call = delete $self->{call}{ refaddr($call) };
188             }
189 22 100       101 if (!$call) {
190 4         36 return; # call was canceled
191             }
192 18         98 return (undef, $response->{result}, $response->{error}, $call);
193             }
194              
195              
196             1; # Magic true value required at end of module
197             __END__