1##############################################################################
2# JSONRPC version 1.1
3# http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html
4##############################################################################
5
6use strict;
7use JSON ();
8use Carp ();
9
10##############################################################################
11
12package JSON::RPC::Client;
13
14$JSON::RPC::Client::VERSION = '0.93';
15
16use LWP::UserAgent;
17
18
19BEGIN {
20    for my $method (qw/uri ua json content_type version id allow_call status_line/) {
21        eval qq|
22            sub $method {
23                \$_[0]->{$method} = \$_[1] if defined \$_[1];
24                \$_[0]->{$method};
25            }
26        |;
27    }
28}
29
30
31
32sub AUTOLOAD {
33    my $self   = shift;
34    my $method = $JSON::RPC::Client::AUTOLOAD;
35
36    $method =~ s/.*:://;
37
38    return if ($method eq 'DESTROY');
39
40    $method =~ s/^__(\w+)__$/$1/;  # avoid to call built-in methods (ex. __VERSION__ => VERSION)
41
42    unless ( exists $self->allow_call->{ $method } ) {
43        Carp::croak("Can't call the method not allowed by prepare().");
44    }
45
46    my @params = @_;
47    my $obj = {
48        method => $method,
49        params => (ref $_[0] ? $_[0] : [@_]),
50    };
51
52    my $ret = $self->call($self->uri, $obj);
53
54    if ( $ret and $ret->is_success ) {
55        return $ret->result;
56    }
57    else {
58        Carp::croak ( $ret ? '(Procedure error) ' . $ret->error_message : $self->status_line );
59    }
60
61}
62
63
64sub create_json_coder {
65    JSON->new->allow_nonref->utf8;
66}
67
68
69sub new {
70    my $proto = shift;
71    my $self  = bless {}, (ref $proto ? ref $proto : $proto);
72
73    my $ua  = LWP::UserAgent->new(
74        agent   => 'JSON::RPC::Client/' . $JSON::RPC::Client::VERSION . ' beta ',
75        timeout => 10,
76    );
77
78    $self->ua($ua);
79    $self->json( $proto->create_json_coder );
80    $self->version('1.1');
81    $self->content_type('application/json');
82
83    return $self;
84}
85
86
87sub prepare {
88    my ($self, $uri, $procedures) = @_;
89    $self->uri($uri);
90    $self->allow_call({ map { ($_ => 1) } @$procedures  });
91}
92
93
94sub call {
95    my ($self, $uri, $obj) = @_;
96    my $result;
97
98    if ($uri =~ /\?/) {
99       $result = $self->_get($uri);
100    }
101    else {
102        Carp::croak "not hashref." unless (ref $obj eq 'HASH');
103        $result = $self->_post($uri, $obj);
104    }
105
106    my $service = $obj->{method} =~ /^system\./ if ( $obj );
107
108    $self->status_line($result->status_line);
109
110    if ($result->is_success) {
111
112        return unless($result->content); # notification?
113
114        if ($service) {
115            return JSON::RPC::ServiceObject->new($result, $self->json);
116        }
117
118        return JSON::RPC::ReturnObject->new($result, $self->json);
119    }
120    else {
121        return;
122    }
123}
124
125
126sub _post {
127    my ($self, $uri, $obj) = @_;
128    my $json = $self->json;
129
130    $obj->{version} ||= $self->{version} || '1.1';
131
132    if ($obj->{version} eq '1.0') {
133        delete $obj->{version};
134        if (exists $obj->{id}) {
135            $self->id($obj->{id}) if ($obj->{id}); # if undef, it is notification.
136        }
137        else {
138            $obj->{id} = $self->id || ($self->id('JSON::RPC::Client'));
139        }
140    }
141    else {
142        $obj->{id} = $self->id if (defined $self->id);
143    }
144
145    my $content = $json->encode($obj);
146
147    $self->ua->post(
148        $uri,
149        Content_Type   => $self->{content_type},
150        Content        => $content,
151        Accept         => 'application/json',
152    );
153}
154
155
156sub _get {
157    my ($self, $uri) = @_;
158    $self->ua->get(
159        $uri,
160        Accept         => 'application/json',
161    );
162}
163
164
165
166##############################################################################
167
168package JSON::RPC::ReturnObject;
169
170$JSON::RPC::ReturnObject::VERSION = $JSON::RPC::VERSION;
171
172BEGIN {
173    for my $method (qw/is_success content jsontext version/) {
174        eval qq|
175            sub $method {
176                \$_[0]->{$method} = \$_[1] if defined \$_[1];
177                \$_[0]->{$method};
178            }
179        |;
180    }
181}
182
183
184sub new {
185    my ($class, $obj, $json) = @_;
186    my $content = ( $json || JSON->new->utf8 )->decode( $obj->content );
187
188    my $self = bless {
189        jsontext  => $obj->content,
190        content   => $content,
191    }, $class;
192
193    $content->{error} ? $self->is_success(0) : $self->is_success(1);
194
195    $content->{version} ? $self->version(1.1) : $self->version(0) ;
196
197    $self;
198}
199
200
201sub is_error { !$_[0]->is_success; }
202
203sub error_message {
204    $_[0]->version ? $_[0]->{content}->{error}->{message} : $_[0]->{content}->{error};
205}
206
207
208sub result {
209    $_[0]->{content}->{result};
210}
211
212
213##############################################################################
214
215package JSON::RPC::ServiceObject;
216
217use base qw(JSON::RPC::ReturnObject);
218
219
220sub sdversion {
221    $_[0]->{content}->{sdversion} || '';
222}
223
224
225sub name {
226    $_[0]->{content}->{name} || '';
227}
228
229
230sub result {
231    $_[0]->{content}->{summary} || '';
232}
233
234
235
2361;
237__END__
238
239
240=pod
241
242
243=head1 NAME
244
245JSON::RPC::Client - Perl implementation of JSON-RPC client
246
247=head1 SYNOPSIS
248
249   use JSON::RPC::Client;
250
251   my $client = new JSON::RPC::Client;
252   my $url    = 'http://www.example.com/jsonrpc/API';
253
254   my $callobj = {
255      method  => 'sum',
256      params  => [ 17, 25 ], # ex.) params => { a => 20, b => 10 } for JSON-RPC v1.1
257   };
258
259   my $res = $client->call($uri, $callobj);
260
261   if($res) {
262      if ($res->is_error) {
263          print "Error : ", $res->error_message;
264      }
265      else {
266          print $res->result;
267      }
268   }
269   else {
270      print $client->status_line;
271   }
272
273
274   # Easy access
275
276   $client->prepare($uri, ['sum', 'echo']);
277   print $client->sum(10, 23);
278
279
280=head1 DESCRIPTION
281
282This is JSON-RPC Client.
283See L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html>.
284
285Gets a perl object and convert to a JSON request data.
286
287Sends the request to a server.
288
289Gets a response returned by the server.
290
291Converts the JSON response data to the perl object.
292
293
294=head1 JSON::RPC::Client
295
296=head2 METHODS
297
298=over
299
300=item $client = JSON::RPC::Client->new
301
302Creates new JSON::RPC::Client object.
303
304=item $response = $client->call($uri, $procedure_object)
305
306Calls to $uri with $procedure_object.
307The request method is usually C<POST>.
308If $uri has query string, method is C<GET>.
309
310About 'GET' method,
311see to L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html#GetProcedureCall>.
312
313Return value is L</JSON::RPC::ReturnObject>.
314
315
316=item $client->prepare($uri, $arrayref_of_procedure)
317
318Allow to call methods in contents of $arrayref_of_procedure.
319Then you can call the prepared methods with an array reference or a list.
320
321The return value is a result part of JSON::RPC::ReturnObject.
322
323   $client->prepare($uri, ['sum', 'echo']);
324
325   $res = $client->echo('foobar');  # $res is 'foobar'.
326
327   $res = $client->sum(10, 20);     # sum up
328   $res = $client->sum( [10, 20] ); # same as above
329
330If you call a method which is not prepared, it will C<croak>.
331
332
333Currently, B<can't call any method names as same as built-in methods>.
334
335=item version
336
337Sets the JSON-RPC protocol version.
3381.1 by default.
339
340
341=item id
342
343Sets a request identifier.
344In JSON-RPC 1.1, it is optoinal.
345
346If you set C<version> 1.0 and don't set id,
347the module sets 'JSON::RPC::Client' to it.
348
349
350=item ua
351
352Setter/getter to L<LWP::UserAgent> object.
353
354
355=item json
356
357Setter/getter to the JSON coder object.
358Default is L<JSON>, likes this:
359
360   $self->json( JSON->new->allow_nonref->utf8 );
361
362   $json = $self->json;
363
364This object serializes/deserializes JSON data.
365By default, returned JSON data assumes UTF-8 encoded.
366
367
368=item status_line
369
370Returns status code;
371After C<call> a remote procedure, the status code is set.
372
373=item create_json_coder
374
375(Class method)
376Returns a JSON de/encoder in C<new>.
377You can override it to use your favorite JSON de/encoder.
378
379
380=back
381
382
383=head1 JSON::RPC::ReturnObject
384
385C<call> method or the methods set by C<prepared> returns this object.
386(The returned JSON data is decoded by the JSON coder object which was passed
387by the client object.)
388
389=head2 METHODS
390
391=over
392
393=item is_success
394
395If the call is successful, returns a true, otherwise a false.
396
397=item is_error
398
399If the call is not successful, returns a true, otherwise a false.
400
401=item error_message
402
403If the response contains an error message, returns it.
404
405=item result
406
407Returns the result part of a data structure returned by the called server.
408
409=item content
410
411Returns the whole data structure returned by the called server.
412
413=item jsontext
414
415Returns the row JSON data.
416
417=item version
418
419Returns the version of this response data.
420
421=back
422
423=head1 JSON::RPC::ServiceObject
424
425
426=head1 RESERVED PROCEDURE
427
428When a client call a procedure (method) name 'system.foobar',
429JSON::RPC::Server look up MyApp::system::foobar.
430
431L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html#ProcedureCall>
432
433L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html#ServiceDescription>
434
435There is JSON::RPC::Server::system::describe for default response of 'system.describe'.
436
437
438=head1 SEE ALSO
439
440L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html>
441
442L<http://json-rpc.org/wiki/specification>
443
444=head1 AUTHOR
445
446Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
447
448
449=head1 COPYRIGHT AND LICENSE
450
451Copyright 2007-2008 by Makamaka Hannyaharamitu
452
453This library is free software; you can redistribute it and/or modify
454it under the same terms as Perl itself.
455
456=cut
457
458
459