1##############################################################################
2package JSON::RPC::Server::Apache2;
3
4use strict;
5
6use lib qw(/var/www/cgi-bin/json/);
7use base qw(JSON::RPC::Server);
8
9use Apache2::Const -compile => qw(OK HTTP_BAD_REQUEST SERVER_ERROR);
10
11use APR::Table ();
12use Apache2::RequestRec ();
13use Apache2::RequestIO ();
14use Apache2::RequestUtil ();
15
16
17$JSON::RPC::Server::Apache::VERSION = '0.05';
18
19
20sub handler {
21    my($r) = @_;
22
23    my $s = __PACKAGE__->new;
24
25    $s->request($r);
26
27    $s->{path_info} = $r->path_info;
28
29    my @modules = $r->dir_config('dispatch') || $r->dir_config('dispatch_to');
30
31    $s->return_die_message( $r->dir_config('return_die_message') );
32
33    $s->dispatch([@modules]);
34
35    $s->handle(@_);
36
37    Apache2::Const::OK;
38}
39
40
41sub new {
42    my $class = shift;
43    return $class->SUPER::new();
44}
45
46
47sub retrieve_json_from_post {
48    my $self = shift;
49    my $r    = $self->request;
50    my $len  = $r->headers_in()->get('Content-Length');
51
52    return if($r->method ne 'POST');
53    return if($len > $self->max_length);
54
55    my ($buf, $content);
56
57    while( $r->read($buf,$len) ){
58        $content .= $buf;
59    }
60
61    $content;
62}
63
64
65sub retrieve_json_from_get {
66    my $self = shift;
67    my $r    = $self->request;
68    my $args = $r->args;
69
70    $args = '' if (!defined $args);
71
72    $self->{path_info} = $r->path_info;
73
74    my $params = {};
75
76    $self->version(1.1);
77
78    for my $pair (split/&/, $args) {
79        my ($key, $value) = split/=/, $pair;
80        if ( defined ( my $val = $params->{ $key } ) ) {
81            if ( ref $val ) {
82                push @{ $params->{ $key } }, $value;
83            }
84            else { # change a scalar into an arrayref
85                $params->{ $key } = [];
86                push @{ $params->{ $key } }, $val, $value;
87            }
88        }
89        else {
90            $params->{ $key } = $value;
91        }
92    }
93
94    my $method = $r->path_info;
95
96    $method =~ s{^.*/}{};
97    $self->{path_info} =~ s{/?[^/]+$}{};
98
99    $self->json->encode({
100        version => '1.1',
101        method  => $method,
102        params  => $params,
103    });
104}
105
106
107sub response {
108    my ($self, $response) = @_;
109    my $r = $self->request;
110
111    $r->content_type($self->content_type);
112    $r->print($response->content);
113
114    return ($response->code == 200)
115            ? Apache2::Const::OK : Apache2::Const::SERVER_ERROR;
116}
117
118
119
1201;
121__END__
122
123
124=pod
125
126
127=head1 NAME
128
129JSON::RPC::Server::Apache2 - JSON-RPC sever for mod_perl2
130
131=head1 SYNOPSIS
132
133 # In apache conf
134
135 PerlRequire /your/path/start.pl
136 PerlModule MyApp
137
138 <Location /jsonrpc/API>
139      SetHandler perl-script
140      PerlResponseHandler JSON::RPC::Server::Apache
141      PerlSetVar dispatch "MyApp"
142      PerlSetVar return_die_message 0
143 </Location>
144
145 #--------------------------
146 # In your application class
147 package MyApp;
148
149 use base qw(JSON::RPC::Procedure); # Perl 5.6 or more than
150
151 sub echo : Public {    # new version style. called by clients
152     # first argument is JSON::RPC::Server object.
153     return $_[1];
154 }
155
156 sub sum : Public(a:num, b:num) { # sets value into object member a, b.
157     my ($s, $obj) = @_;
158     # return a scalar value or a hashref or an arryaref.
159     return $obj->{a} + $obj->{b};
160 }
161
162 sub a_private_method : Private {
163     # ... can't be called by client
164 }
165
166 sub sum_old_style {  # old version style. taken as Public
167     my ($s, @arg) = @_;
168    return $arg[0] + $arg[1];
169 }
170
171=head1 DESCRIPTION
172
173Gets a client request.
174
175Parses its JSON data.
176
177Passes the server object and the object decoded from the JSON data to your procedure (method).
178
179Takes your returned value (scalar or arrayref or hashref).
180
181Sends a response.
182
183Well, you write your procedure code only.
184
185
186=head1 METHODS
187
188They are inherited from the L<JSON::RPC::Server> methods basically.
189The below methods are implemented in JSON::RPC::Server::Apache2.
190
191=over
192
193=item new
194
195Creates new JSON::RPC::Server::Apache2 object.
196
197=item handle
198
199Runs server object and returns a response.
200
201=item retrieve_json_from_post
202
203retrieves a JSON request from the body in POST method.
204
205=item retrieve_json_from_get
206
207In the protocol v1.1, 'GET' request method is also allowable.
208it retrieves a JSON request from the query string in GET method.
209
210=item response
211
212returns a response JSON data to a client.
213
214=back
215
216=head1 SEE ALSO
217
218L<JSON::RPC::Server>,
219
220L<JSON::RPC::Procedure>,
221
222L<JSON>,
223
224L<http://json-rpc.org/wd/JSON-RPC-1-1-WD-20060807.html>,
225
226L<http://json-rpc.org/wiki/specification>,
227
228=head1 AUTHOR
229
230Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
231
232
233=head1 COPYRIGHT AND LICENSE
234
235Copyright 2007-2008 by Makamaka Hannyaharamitu
236
237This library is free software; you can redistribute it and/or modify
238it under the same terms as Perl itself.
239
240=cut
241
242
243