File Coverage

blib/lib/JSON/RPC/Legacy/Client.pm
Criterion Covered Total %
statement 19 106 17.9
branch 0 66 0.0
condition 0 14 0.0
subroutine 7 33 21.2
pod 9 12 75.0
total 35 231 15.1


line stmt bran cond sub pod time code
1             ##############################################################################
2             # JSONRPC version 1.1
3             # http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html
4             ##############################################################################
5              
6 1     1   27514 use strict;
  1         1  
  1         28  
7 1     1   628 use JSON ();
  1         8889  
  1         21  
8 1     1   4 use Carp ();
  1         2  
  1         31  
9              
10             ##############################################################################
11              
12             package JSON::RPC::Legacy::Client;
13              
14             $JSON::RPC::Legacy::Client::VERSION = '1.06';
15              
16 1     1   562 use LWP::UserAgent;
  1         31687  
  1         52  
17              
18              
19             BEGIN {
20 1     1   2 for my $method (qw/uri ua json content_type version id allow_call status_line/) {
21 8 0   0 0 922 eval qq|
  0 0   0 0    
  0 0   0 1    
  0 0   0 1    
  0 0   0 1    
  0 0   0 1    
  0 0   0 0    
  0 0   0 1    
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
22             sub $method {
23             \$_[0]->{$method} = \$_[1] if defined \$_[1];
24             \$_[0]->{$method};
25             }
26             |;
27             }
28             }
29              
30              
31              
32             sub AUTOLOAD {
33 0     0     my $self = shift;
34 0           my $method = $JSON::RPC::Legacy::Client::AUTOLOAD;
35              
36 0           $method =~ s/.*:://;
37              
38 0 0         return if ($method eq 'DESTROY');
39              
40 0           $method =~ s/^__(\w+)__$/$1/; # avoid to call built-in methods (ex. __VERSION__ => VERSION)
41              
42 0 0         unless ( exists $self->allow_call->{ $method } ) {
43 0           Carp::croak("Can't call the method not allowed by prepare().");
44             }
45              
46 0           my @params = @_;
47 0 0         my $obj = {
48             method => $method,
49             params => (ref $_[0] ? $_[0] : [@_]),
50             };
51              
52 0           my $ret = $self->call($self->uri, $obj);
53              
54 0 0 0       if ( $ret and $ret->is_success ) {
55 0           return $ret->result;
56             }
57             else {
58 0 0         Carp::croak ( $ret ? '(Procedure error) ' . $ret->error_message : $self->status_line );
59             }
60              
61             }
62              
63              
64             sub create_json_coder {
65 0     0 1   JSON->new->allow_nonref->utf8;
66             }
67              
68              
69             sub new {
70 0     0 1   my $proto = shift;
71 0 0         my $self = bless {}, (ref $proto ? ref $proto : $proto);
72              
73 0           my $ua = LWP::UserAgent->new(
74             agent => 'JSON::RPC::Legacy::Client/' . $JSON::RPC::Legacy::Client::VERSION . ' beta ',
75             timeout => 10,
76             );
77              
78 0           $self->ua($ua);
79 0           $self->json( $proto->create_json_coder );
80 0           $self->version('1.1');
81 0           $self->content_type('application/json');
82              
83 0           return $self;
84             }
85              
86              
87             sub prepare {
88 0     0 1   my ($self, $uri, $procedures) = @_;
89 0           $self->uri($uri);
90 0           $self->allow_call({ map { ($_ => 1) } @$procedures });
  0            
91             }
92              
93              
94             sub call {
95 0     0 1   my ($self, $uri, $obj) = @_;
96 0           my $result;
97              
98 0 0         if ($uri =~ /\?/) {
99 0           $result = $self->_get($uri);
100             }
101             else {
102 0 0         Carp::croak "not hashref." unless (ref $obj eq 'HASH');
103 0           $result = $self->_post($uri, $obj);
104             }
105              
106 0 0         my $service = $obj->{method} =~ /^system\./ if ( $obj );
107              
108 0           $self->status_line($result->status_line);
109              
110 0 0         return unless($result->content); # notification?
111              
112 0 0         if ($service) {
113 0           return JSON::RPC::Legacy::ServiceObject->new($result, $self->json);
114             }
115              
116 0           return JSON::RPC::Legacy::ReturnObject->new($result, $self->json);
117             }
118              
119              
120             sub _post {
121 0     0     my ($self, $uri, $obj) = @_;
122 0           my $json = $self->json;
123              
124 0   0       $obj->{version} ||= $self->{version} || '1.1';
      0        
125              
126 0 0         if ($obj->{version} eq '1.0') {
127 0           delete $obj->{version};
128 0 0         if (exists $obj->{id}) {
129 0 0         $self->id($obj->{id}) if ($obj->{id}); # if undef, it is notification.
130             }
131             else {
132 0   0       $obj->{id} = $self->id || ($self->id('JSON::RPC::Legacy::Client'));
133             }
134             }
135             else {
136 0 0         $obj->{id} = $self->id if (defined $self->id);
137             }
138              
139 0           my $content = $json->encode($obj);
140              
141 0           $self->ua->post(
142             $uri,
143             Content_Type => $self->{content_type},
144             Content => $content,
145             Accept => 'application/json',
146             );
147             }
148              
149              
150             sub _get {
151 0     0     my ($self, $uri) = @_;
152 0           $self->ua->get(
153             $uri,
154             Accept => 'application/json',
155             );
156             }
157              
158              
159              
160             ##############################################################################
161              
162             package JSON::RPC::Legacy::ReturnObject;
163              
164             $JSON::RPC::Legacy::ReturnObject::VERSION = $JSON::RPC::Legacy::VERSION;
165              
166             BEGIN {
167 1     1   2 for my $method (qw/is_success content jsontext version/) {
168 4 0   0   328 eval qq|
  0 0   0      
  0 0   0      
  0 0   0      
  0            
  0            
  0            
  0            
  0            
169             sub $method {
170             \$_[0]->{$method} = \$_[1] if defined \$_[1];
171             \$_[0]->{$method};
172             }
173             |;
174             }
175             }
176              
177              
178             sub new {
179 0     0     my ($class, $obj, $json) = @_;
180 0   0       my $content = ( $json || JSON->new->utf8 )->decode( $obj->content );
181              
182 0           my $self = bless {
183             jsontext => $obj->content,
184             content => $content,
185             }, $class;
186              
187 0 0         $content->{error} ? $self->is_success(0) : $self->is_success(1);
188              
189 0 0         $content->{version} ? $self->version(1.1) : $self->version(0) ;
190              
191 0           $self;
192             }
193              
194              
195 0     0     sub is_error { !$_[0]->is_success; }
196              
197             sub error_message {
198 0 0   0     $_[0]->version ? $_[0]->{content}->{error}->{message} : $_[0]->{content}->{error};
199             }
200              
201              
202             sub result {
203 0     0     $_[0]->{content}->{result};
204             }
205              
206              
207             ##############################################################################
208              
209             package JSON::RPC::Legacy::ServiceObject;
210              
211 1     1   5 use base qw(JSON::RPC::Legacy::ReturnObject);
  1         7  
  1         393  
212              
213              
214             sub sdversion {
215 0 0   0     $_[0]->{content}->{sdversion} || '';
216             }
217              
218              
219             sub name {
220 0 0   0     $_[0]->{content}->{name} || '';
221             }
222              
223              
224             sub result {
225 0 0   0     $_[0]->{content}->{summary} || '';
226             }
227              
228              
229              
230             1;
231             __END__