File Coverage

lib/Catalyst/Plugin/Server/XMLRPC.pm
Criterion Covered Total %
statement 176 197 89.3
branch 45 66 68.2
condition 25 50 50.0
subroutine 26 29 89.7
pod 0 5 0.0
total 272 347 78.4


line stmt bran cond sub pod time code
1             =head1 NAME
2            
3             Catalyst::Plugin::Server::XMLRPC -- Catalyst XMLRPC Server Plugin
4            
5             =head1 SYNOPSIS
6            
7             package MyApp;
8             use Catalyst qw/Server Server::XMLRPC/;
9            
10             package MyApp::Controller::Example;
11             use base 'Catalyst::Controller';
12            
13             sub echo : XMLRPC { # available as: example.echo
14             my ( $self, $c, @args ) = @_;
15             $c->stash->{xmlrpc} = join ', ', @args;
16             }
17            
18             sub ping : XMLRPCPath('/ping') { # available as: ping
19             my ( $self, $c ) = @_;
20             $c->stash->{xmlrpc} = 'Pong';
21             }
22            
23             sub world : XMLRPCRegex(/hello/) { # available as: *hello*
24             my ($self, $c) = @_;
25             $c->stash->{xmlrpc} = 'World';
26             }
27            
28             sub echo : XMLRPCLocal { # available as: example.echo
29             my ( $self, $c, @args ) = @_;
30             $c->stash->{xmlrpc} = join ', ', @args;
31             }
32            
33             sub ping : XMLRPCGlobal { # available as: ping
34             my ( $self, $c ) = @_;
35             $c->stash->{xmlrpc} = 'Pong';
36             }
37            
38             =head1 DESCRIPTION
39            
40             XMLRPC Plugin for Catalyst which we tried to make compatible with the
41             way Catalyst works with URLS. Main features are:
42            
43             =over 4
44            
45             =item * Split XMLRPC methodNames by STRING to find out Controller.
46            
47             =item * Single entrypoint for XMLRPC calls, like http://host.tld/rpc
48            
49             =item * DispatchTypes (attributes) which work much the same as Catalyst attrs
50            
51             =item * XMLRPC Parameter handling transparent to Catalyst parameter handling
52            
53             =back
54            
55             =head1 HOW IT WORKS
56            
57             The default behaviour will handle XMLRPC Requests sent to C</rpc> by creating
58             an OBJECT containing XMLRPC specific parameters in C<< $c->req->xmlrpc >>.
59            
60             Directly after, it will find out the Path of the Action to dispatch to, by
61             splitting methodName by C<.>:
62            
63             methodName: hello.world
64             path : /hello/world
65            
66             From this point, it will dispatch to '/hello/world' when it exists,
67             like Catalyst Urls would do. What means: you will be able to set Regexes,
68             Paths etc on subroutines to define the endpoint.
69            
70             We discuss these custom XMLRPC attributes below.
71            
72             When the request is dispatched, we will return $c->stash->{xmlrpc} to the
73             xmlrpc client, or, when it is not available, it will return $c->stash to
74             the client. There is also a way of defining $c->stash keys to be send back
75             to the client.
76            
77             =head1 ATTRIBUTES
78            
79             You can mark any method in your Catalyst application as being
80             available remotely by using one of the following attributes,
81             which can be added to any existing attributes, except Private.
82             Remember that one of the mentioned attributes below are automatically
83             also Privates...
84            
85             =over 4
86            
87             =item XMLRPC
88            
89             Make this method accessible via XMLRPC, the same way as Local does
90             when using catalyst by URL.
91            
92             The following example will be accessible by method C<< hello.world >>:
93            
94             package Catalyst::Controller::Hello
95             sub world : XMLRPC {}
96            
97             =item XMLRPCLocal
98            
99             Identical version of attribute C<XMLRPC>
100            
101             =item XMLRPCGlobal
102            
103             Make this method accessible via XMLRPC, the same way as GLOBAL does
104             when using catalyst by URL.
105            
106             The following example will be accessible by method C<< ping >>:
107            
108             package Catalyst::Controller::Hello
109             sub ping : XMLRPCGlobal {}
110            
111             =item XMLRPCPath('/say/hello')
112            
113             Make this method accessible via XMLRPC, the same way as Path does
114             when using catalyst by URL.
115            
116             The following example will be accessible by method C<< say.hello >>:
117            
118             package Catalyst::Controller::Hello
119             sub hello : XMLRPCPath('/say/hello') {}
120            
121             =item XMLRPCRegex('foo')
122            
123             Make this method accessible via XMLRPC, the same way as Regex does
124             when using catalyst by URL.
125            
126             The following example will be accessible by example methods:
127             C<< a.foo.method >>
128             C<< wedoofoohere >>
129             C<< foo.getaround >>
130            
131             package Catalyst::Controller::Hello
132             sub hello : XMLRPCPath('foo') {}
133            
134             =back
135            
136             =head1 ACCESSORS
137            
138             Once you've used the plugin, you'll have an $c->request->xmlrpc accessor
139             which will return an C<Catalyst::Plugin::Server::XMLRPC> object.
140            
141             You can query this object as follows:
142            
143             =over 4
144            
145             =item $c->req->xmlrpc->is_xmlrpc_request
146            
147             Boolean indicating whether the current request has been initiated
148             via XMLRPC
149            
150             =item $c->req->xmlrpc->config
151            
152             Returns a C<Catalyst::Plugin::Server::XMLRPC::Config> object. See the
153             C<CONFIGURATION> below on how to use and configure it.
154            
155             =item $c->req->xmlrpc->body
156            
157             The body of the original XMLRPC call
158            
159             =item $c->req->xmlrpc->method
160            
161             The name of the original method called via XMLRPC
162            
163             =item $c->req->xmlrpc->args
164            
165             A list of parameters supplied by the XMLRPC call
166            
167             =item $c->req->xmlrpc->result_as_string
168            
169             The XML body that will be sent back to the XMLRPC client
170            
171             =item $c->req->xmlrpc->error
172            
173             Allows you to set xmlrpc fault code and message
174            
175             =back
176            
177             =head1 Server Accessors
178            
179             The following accessors are always available, whether you're in a xmlrpc
180             specific request or not
181            
182             =over 4
183            
184             =item $c->server->xmlrpc->list_methods
185            
186             Returns a HASHREF containing the available xmlrpc methods in Catalyst as
187             a key, and the C<Catalyst::Action> object as a value.
188            
189             =back
190            
191             =head1 CATALYST REQUEST
192            
193             To make things transparent, we try to put XMLRPC params into the Request
194             object of Catalyst. But first we will explain something about the XMLRPC
195             specifications.
196            
197             A full draft of these specifications can be found on:
198             C<http://www.xmlrpc.com/spec>
199            
200             In short, a xmlrpc-request consists of a methodName, like a subroutine
201             name, and a list of parameters. This list of parameters may contain strings
202             (STRING), arrays (LIST) and structs (HASH). Off course, these can be nested.
203            
204             =over 4
205            
206             =item $c->req->arguments
207            
208             We will put the list of arguments into $c->req->arguments, thisway you can
209             fetch this list within your dispatched-to-subroutine:
210            
211             sub echo : XMLRPC {
212             my ($self, $c, @args) = @_;
213             $c->log->debug($arg[0]); # Prints first XMLRPC parameter
214             # to debug log
215             }
216            
217             =item $c->req->parameters
218            
219             Because XMLRPC parameters are a LIST, we can't B<just> fill
220             $c->req->paremeters. To keep things transparent, we made an extra config
221             option what tells the XMLRPC server we can assume the following conditions
222             on all XMLRPC requests:
223             - There is only one XMLRPC parameter
224             - This XMLRPC parameter is a struct (HASH)
225            
226             We will put this STRUCT as key-value pairs into $c->req->parameters.
227            
228             =item $c->req->params
229            
230             Alias of $c->req->parameters
231            
232             =item $c->req->param
233            
234             Alias of $c->req->parameters
235            
236             =back
237            
238             =cut
239              
240             {   package Catalyst::Plugin::Server::XMLRPC;
241              
242 7     7   230     use strict;
  7         179  
  7         145  
243 7     7   137     use warnings;
  7         64  
  7         112  
244 7     7   124     use attributes ();
  7         64  
  7         147  
245              
246 7     7   211     use Data::Dumper;
  7         69  
  7         192  
247              
248                 my $ServerClass = 'Catalyst::Plugin::Server::XMLRPC::Backend';
249              
250             ### only for development dumps!
251                 my $Debug = 0;
252              
253             ###
254             ### Catalyst loading and dispatching
255             ###
256              
257             ### Loads our xmlrpc backend class in $c->server->xmlrpc
258                 sub setup_engine {
259 6     6 0 62         my $class = shift;
260 6         128         $class->server->register_server(
261                                 'xmlrpc' => $ServerClass->new($class)
262                             );
263 6         191         $class->NEXT::setup_engine(@_);
264                 }
265              
266             ### Will load our customized DispatchTypes into Catalyst
267                 sub setup_dispatcher {
268 6     6 0 59         my $class = shift;
269              
270             ### Load custom DispatchTypes
271 6         2363         $class->NEXT::setup_dispatcher( @_ );
272 6         72         $class->dispatcher->preload_dispatch_types(
273 6         85             @{$class->dispatcher->preload_dispatch_types},
274                         qw/ +Catalyst::Plugin::Server::XMLRPC::DispatchType::XMLRPCPath
275             +Catalyst::Plugin::Server::XMLRPC::DispatchType::XMLRPCRegex/
276                     );
277              
278 6         108         return $class;
279                 }
280              
281             ### Loads the xmlrpc-server object, redispatch to the method
282                 sub prepare_action {
283 21     21 0 205         my $c = shift;
284 21         196         my @args = @_;
285              
286             ### set up the accessor to hold an xmlrpc server instance
287 21         260         $c->req->register_server(
288                         'xmlrpc' => Catalyst::Plugin::Server::XMLRPC::Request->new()
289                     );
290              
291             ### are we an xmlrpc call? check the path against a regex
292 21         873         my $path = $c->server->xmlrpc->config->path;
293 21 100       1978         if( $c->req->path =~ /$path/) {
294              
295 19         269             PREPARE: {
296             ### mark us as an xmlrpc request
297 19         1346                 $c->req->xmlrpc->is_xmlrpc_request(1);
298              
299 19 50       245                 $c->log->debug( 'PREPARE WITH $c ' . Dumper ($c ) ) if $Debug;
300              
301 19 100       248                 $c->req->xmlrpc->_deserialize_xml( $c ) or last PREPARE;
302              
303             ### CAVEAT: we consider backing up to a default for a
304             ### xml-rpc method when the method doesn't exist a security
305             ### risk. So when the exact method doesn't exist, we return
306             ### an error.
307             ### TODO ARGH Because of regex methods, this won't work
308              
309             ### set the new request path, the one we will forward to
310 17         231                 $c->req->path( $c->req->xmlrpc->forward_path );
311              
312             ### filter change dispatch types to our OWN
313 17   50     4277                 { my $saved_dt = $c->dispatcher->dispatch_types || [];
  17         264  
314 17         1191                     my $dp_ns
315                                     = 'Catalyst::Plugin::Server::XMLRPC::DispatchType::';
316              
317 102 100       5661                     $c->dispatcher->dispatch_types(
318                                     [ grep {
319 17         244                             UNIVERSAL::isa(
320                                                 $_, $dp_ns . 'XMLRPCPath'
321                                             ) or
322                                         UNIVERSAL::isa(
323                                                 $_, $dp_ns . 'XMLRPCRegex'
324                                             )
325                                         } @$saved_dt
326                                     ]
327                                 );
328              
329             ### run the rest of the prepare actions, we should have
330             ### an action object now
331 17         632                     $c->NEXT::prepare_action( @_ );
332              
333             ### restore the saved dispatchtypes
334 17         38710                     $c->dispatcher->dispatch_types( $saved_dt );
335                             }
336              
337             ### check if we have a c->action now
338             ### check if the NEW action isn't hte same as the
339             ### OLD action -- which mean no method was found
340             ### Not needed, don't have an action until we NEXT
341 17 100 66     6498                 if( (not $c->action) &&
342                                 !$c->server->xmlrpc->private_methods->{
343                                                             $c->req->xmlrpc->method
344                                                         }
345                             ) {
346 4         113                     $c->req->xmlrpc->_error(
347                                     $c, qq[Invalid XMLRPC request: No such method]
348                                 );
349 4         170                     last PREPARE;
350                             }
351                         }
352              
353             ### XMLRPC parameters and argument processing, see the Request
354             ### class below for information why we can't do it there.
355 19 50       770             $c->req->parameters( $c->req->xmlrpc->params )
356                                     if $c->server->xmlrpc->config->convert_params;
357              
358 19         1661             $c->req->args($c->req->xmlrpc->args );
359              
360             ### we're no xmlrpc request, so just let others handle it
361                     } else {
362 2         100             $c->NEXT::prepare_action( @_ );
363                     }
364                 }
365              
366             ### before we dispatch, make sure no xmlrpc errors have happened already,
367             ### or an internal method has been called.
368                 sub dispatch {
369 21     21 0 650         my $c = shift;
370              
371 21 100 100     436         if( $c->req->xmlrpc->is_xmlrpc_request and
  19 50 66     298  
372                         scalar( @{ $c->error } )
373                     ) {
374 6         153             1;
375                     } elsif (
376                             $c->req->xmlrpc->is_xmlrpc_request and
377                             $c->server->xmlrpc->private_methods->{$c->req->xmlrpc->method}
378                     ) {
379 0         0                 $c->req->xmlrpc->run_method($c);
380                     } else {
381 15         281             $c->NEXT::dispatch( @_ );
382                     }
383                 }
384              
385                 sub finalize {
386 21     21 0 5669         my $c = shift;
387              
388 21 100       271         if( $c->req->xmlrpc->is_xmlrpc_request ) {
389              
390             ### if we got an error anywhere, we'll return a fault
391             ### othwerise, the resultset will be returned
392             ### XXX TODO make error codes configurable ( done )
393             ### XXX TODO make messages customizable ( done )
394 19         160             my $res;
395 19         262             my $req_error = $c->req->xmlrpc->error;
396 19 100 100     173             if( scalar @{ $c->error } or $req_error ) {
  19         213  
397 7 50     &