File Coverage

blib/lib/JSON/RPC2/TwoWay.pm
Criterion Covered Total %
statement 84 99 84.8
branch 37 62 59.6
condition 19 28 67.8
subroutine 21 24 87.5
pod 4 4 100.0
total 165 217 76.0


line stmt bran cond sub pod time code
1             package JSON::RPC2::TwoWay;
2 2     2   84348 use 5.10.0;
  2         19  
3 2     2   10 use strict;
  2         4  
  2         52  
4 2     2   11 use warnings;
  2         4  
  2         134  
5              
6             our $VERSION = '0.07'; # VERSION
7              
8             # standard perl
9 2     2   27 use Carp;
  2         4  
  2         144  
10 2     2   629 use Data::Dumper;
  2         6759  
  2         119  
11              
12             # cpan
13 2     2   20 use JSON::MaybeXS qw();
  2         6  
  2         38  
14              
15             # us
16 2     2   954 use JSON::RPC2::TwoWay::Connection;
  2         6  
  2         72  
17              
18 2     2   13 use constant ERR_NOTNOT => -32000;
  2         4  
  2         112  
19 2     2   12 use constant ERR_ERR => -32001;
  2         4  
  2         100  
20 2     2   12 use constant ERR_BADSTATE => -32002;
  2         10  
  2         95  
21 2     2   10 use constant ERR_REQ => -32600;
  2         4  
  2         125  
22 2     2   12 use constant ERR_METHOD => -32601;
  2         3  
  2         99  
23 2     2   22 use constant ERR_PARAMS => -32602;
  2         3  
  2         86  
24 2     2   11 use constant ERR_PARSE => -32700;
  2         13  
  2         2251  
25              
26             sub new {
27 1     1 1 91 my ($class, %opt) = @_;
28             my $self = {
29             debug => $opt{debug} ? 1 : 0,
30 0     0   0 log => ref $opt{debug} eq 'CODE' ? $opt{debug} : sub { say STDERR @_ },
31 1 50 33     15 json => $opt{json} // JSON::MaybeXS->new(utf8 => 1),
    50          
32             methods => {},
33             };
34 1         30 return bless $self, $class;
35             }
36              
37             sub newconnection {
38 2     2 1 1238 my ($self, %opt) = @_;
39             my $conn = JSON::RPC2::TwoWay::Connection->new(
40             rpc => $self,
41             owner => $opt{owner},
42             write => $opt{write},
43             debug => $self->{debug} ? $self->{log} : 0,
44             json => $self->{json},
45 2 50       20 );
46 1         4 return $conn
47             }
48              
49             sub register {
50 7     7 1 3046 my ($self, $name, $cb, %opts) = @_;
51 7         27 my %defaults = (
52             by_name => 1,
53             non_blocking => 0,
54             notification => 0,
55             raw => 0,
56             state => undef,
57             );
58 7 50       21 croak 'no self?' unless $self;
59 7 50       15 croak 'no name?' unless $name;
60 7 100       230 croak 'no callback?' unless ref $cb eq 'CODE';
61 6         23 %opts = (%defaults, %opts);
62             croak 'a non_blocking notification is not sensible'
63 6 100 100     100 if $opts{non_blocking} and $opts{notification};
64 5 100       88 croak "method $name already registered" if $self->{methods}->{$name};
65             $self->{methods}->{$name} = {
66             name => $name,
67             cb => $cb,
68             by_name => $opts{by_name},
69             non_blocking => $opts{non_blocking},
70             notification => $opts{notification},
71             raw => $opts{raw},
72             state => $opts{state},
73 4         24 };
74             }
75              
76             sub unregister {
77 0     0 1 0 my ($self, $name) = @_;
78 0 0       0 croak 'no self?' unless $self;
79 0 0       0 croak 'no name?' unless $name;
80 0         0 my $method = delete $self->{methods}->{$name};
81 0 0       0 croak "method $name already registered" unless $method;
82             }
83              
84              
85             sub _handle_request {
86 9     9   19 my ($self, $c, $r) = @_;
87 9 50       20 $self->{log}->(' in handle_request') if $self->{debug};
88             #print Dumper(\@_);
89 9         20 my $m = $self->{methods}->{$r->{method}};
90 9         15 my $id = $r->{id};
91 9 100       22 return $self->_error($c, $id, ERR_METHOD, 'Method not found.') unless $m;
92 8 100 100     56 return $self->_error($c, $id, ERR_NOTNOT, 'Method is not a notification.') if !$id and !$m->{notification};
93              
94             return $self->_error($c, $id, ERR_REQ, 'Invalid Request: params should be array or object.')
95 7 100 100     33 if ref $r->{params} ne 'ARRAY' and ref $r->{params} ne 'HASH';
96              
97             return $self->_error($c, $id, ERR_PARAMS, 'This method expects '.($m->{by_name} ? 'named' : 'positional').' params.')
98 6 100       28 if ref $r->{params} ne ($m->{by_name} ? 'HASH' : 'ARRAY');
    100          
    100          
99            
100             return $self->_error($c, $id, ERR_BADSTATE, 'This method requires connection state ' . ($m->{state} // 'undef'))
101 4 100 50     15 if $m->{state} and not ($c->state and $m->{state} eq $c->state);
      66        
      100        
102              
103 3 50       9 if ($m->{raw}) {
104 0         0 my $cb;
105 0 0   0   0 $cb = sub { $c->write($self->{json}->encode($_[0])) if $id } if $m->{non_blocking};
  0 0       0  
106              
107 0         0 local $@;
108             #my @ret = eval { $m->{cb}->($c, $jsonr, $r, $cb)};
109 0         0 my @ret = eval { $m->{cb}->($c, $r, $cb)};
  0         0  
110 0 0       0 return $self->_error($c, $id, ERR_ERR, "Method threw error: $@") if $@;
111             #$self->{log}->('method returned: ' . Dumper(\@ret)) if $self->{debug};
112              
113 0 0 0     0 $c->write($self->{json}->encode($ret[0])) if !$cb and $id;
114             return
115 0         0 }
116              
117 3         4 my $cb;
118 3 50   1   12 $cb = sub { $self->_result($c, $id, \@_) if $id; } if $m->{non_blocking};
  1 100       853  
119              
120 3         4 local $@;
121 3         6 my @ret = eval { $m->{cb}->($c, $r->{params}, $cb)};
  3         9  
122 3 50       18 return $self->_error($c, $id, ERR_ERR, "Method threw error: $@") if $@;
123             #$self->{log}->('method returned: ' . Dumper(\@ret)) if $self->{debug};
124            
125 3 100 66     15 return $self->_result($c, $id, \@ret) if !$cb and $id;
126 1         5 return;
127             }
128              
129             sub _error {
130 11     11   29 my ($self, $c, $id, $code, $message, $data) = @_;
131 11   50     36 my $err = "error: $code " . $message // '';
132 11 50       25 $self->{log}->($err) if $self->{debug};
133             $c->write($self->{json}->encode({
134 11 50       126 jsonrpc => '2.0',
135             id => $id,
136             error => {
137             code => $code,
138             message => $message,
139             (defined $data ? ( data => $data ) : ()),
140             },
141             }));
142 11         102 return 0, $err;
143             }
144              
145             sub _result {
146 3     3   10 my ($self, $c, $id, $result) = @_;
147 3 100       9 $result = $$result[0] if scalar(@$result) == 1;
148             #$self->{log}->(Dumper($result)) if $self->{debug};
149             $c->write($self->{json}->encode({
150 3         46 jsonrpc => '2.0',
151             id => $id,
152             result => $result,
153             }));
154 3         22 return;
155             }
156              
157             #sub DESTROY {
158             # my $self = shift;
159             # $self->{log}->('destroying ' . $self) if $self->{debug};
160             #}
161              
162             1;
163              
164             =encoding utf8
165              
166             =head1 NAME
167              
168             JSON::RPC2::TwoWay - Transport-independent bidirectional JSON-RPC 2.0
169              
170             =head1 SYNOPSIS
171              
172             $rpc = JSON::RPC2::TwoWay->new();
173             $rpc->register('ping', \&handle_ping);
174              
175             $con = $rpc->newconnection(
176             owner => $owner,
177             write => sub { $stream->write(@_) }
178             );
179             @err = $con->handle($stream->read);
180             die $err[-1] if @err;
181              
182             =head1 DESCRIPTION
183              
184             L is a base class to implement bidirectional (a.k.a.
185             twoway) communication using JSON-RPC 2.0 remote procedure calls: both sides
186             can operate as Clients and Servers simultaneously. This class is
187             transport-independent.
188              
189             =head1 METHODS
190              
191             =head2 new
192              
193             $rpc = JSON::RPC2::TwoWay->new();
194              
195             Class method that returns a new JSON::RPC2::TwoWay object.
196              
197             Valid arguments are:
198              
199             =over 4
200              
201             =item - debug: print debugging to STDERR, or if coderef is given call that with
202             the debugging line.
203              
204             =item - json: json encoder/decoder object to use. Defaults to JSON::MaybeXS->new().
205              
206             =back
207              
208             =head2 newconnection
209              
210             my $con = $rpc->newconnection(owner => $owner, write = $write);
211              
212             Creates a L with owner $owner and writer $write.
213              
214             See L for details.
215              
216             =head2 register
217              
218             $rpc->register('my_method', sub { ... }, option => ... );
219              
220             Register a new method to be callable. Calls are passed to the callback.
221              
222             Valid options are:
223              
224             =over 4
225              
226             =item - by_name
227              
228             When true the arguments to the method will be passed in as a hashref,
229             otherwise as a arrayref. (default true)
230              
231             =item - non_blocking
232              
233             When true the method callback will receive a callback as its last argument
234             for passing back the results (default false)
235              
236             =item - notification
237              
238             When true the method is a notification and no return value is expected by
239             the caller. (Any returned values will be discarded in the handler.)
240              
241             =item - state
242              
243             When defined must be a string value defining the state the connection (see
244             L) must be in for this call to be accepted.
245              
246             =back
247              
248             =head2 unregister
249              
250             $rpc->unregister('my_method')
251              
252             Unregister a method.
253              
254             =head1 REGISTERED CALLBACK CALLING CONVENTION
255              
256             The method callback passed as the second argument of register is called with
257             2 or 3 arguments: the first argument is the JSON::RPC2::TwoWay::Connection
258             object on which the request came in. The second argument is a arrayref or
259             hashref depending on if the method was registered as by-position or by-name.
260             The third argument, if present is a result callback that needs to be called
261             with the results of the method:
262              
263             sub mymethod {
264             ($c, $i, $cb) = @_;
265             $foo = $i->{foo};
266             }
267              
268             some time later;
269              
270             $cb->("you sent $foo");
271              
272             If the method callback returns a scalar value the JSON-RPC 2.0 result member
273             value will be a JSON string, number, or null value. If the method returns a
274             hashref the result member value will be an object. If the method returns
275             multiple values or an arrayref the result member value will be an array.
276              
277             =head1 SEE ALSO
278              
279             =over
280              
281             =item *
282              
283             L
284              
285             =item *
286              
287             L: JSON-RPC 2.0 Specification
288              
289             =back
290              
291             =head1 ACKNOWLEDGEMENT
292              
293             This software has been developed with support from L.
294             In German: Diese Software wurde mit Unterstützung von L entwickelt.
295              
296             =head1 THANKS
297              
298             =over 4
299              
300             =item *
301              
302             'greencoloured' for multiple PRs
303              
304             =back
305              
306             =head1 AUTHORS
307              
308             =over 4
309              
310             =item *
311              
312             Wieger Opmeer
313              
314             =back
315              
316             =head1 COPYRIGHT AND LICENSE
317              
318             This software is copyright (c) 2016-2022 by Wieger Opmeer.
319              
320             This is free software; you can redistribute it and/or modify it under
321             the same terms as the Perl 5 programming language system itself.
322              
323             =cut
324