File Coverage

blib/lib/Catalyst/Plugin/XMLRPC.pm
Criterion Covered Total %
statement 71 76 93.4
branch 7 14 50.0
condition 2 6 33.3
subroutine 12 12 100.0
pod 2 2 100.0
total 94 110 85.5


line stmt bran cond sub pod time code
1             package Catalyst::Plugin::XMLRPC;
2              
3 2     2   52 use strict;
  2         46  
  2         55  
4 2     2   92 use base 'Class::Data::Inheritable';
  2         36  
  2         32  
5 2     2   55 use attributes ();
  2         19  
  2         21  
6 2     2   96 use RPC::XML;
  2         22  
  2         52  
7 2     2   77 use RPC::XML::Parser;
  2         22  
  2         48  
8 2     2   80 use Catalyst::Action;
  2         21  
  2         44  
9 2     2   49 use Catalyst::Utils;
  2         55  
  2         53  
10 2     2   67 use NEXT;
  2         19  
  2         39  
11              
12             our $VERSION = '1.0';
13              
14             __PACKAGE__->mk_classdata('_xmlrpc_parser');
15             __PACKAGE__->_xmlrpc_parser( RPC::XML::Parser->new );
16              
17             =head1 NAME
18            
19             Catalyst::Plugin::XMLRPC - Dispatch XMLRPC methods with Catalyst
20            
21             =head1 SYNOPSIS
22            
23             # Include it in plugin list
24             use Catalyst qw/XMLRPC/;
25            
26             # Public action to redispatch somewhere in a controller
27             sub entrypoint : Global {
28             my ( $self, $c ) = @_;
29            
30             # Redispatch to XMLRPC methods by calling this method
31             $c->xmlrpc;
32             }
33            
34             # Methods with XMLRPC attribute in any controller
35             sub echo : XMLRPC('myAPI.echo') {
36             my ( $self, $c, @args ) = @_;
37             return RPC::XML::fault->new( 400, "No input!" ) unless @args;
38             return join ' ', @args;
39             }
40            
41             sub add : XMLRPC {
42             my ( $self, $c, $a, $b ) = @_;
43             return $a + $b;
44             }
45            
46             =head1 DESCRIPTION
47            
48             This plugin allows your controller class to dispatch XMLRPC methods
49             from its own class.
50            
51             =head1 METHODS
52            
53             =head2 $c->xmlrpc
54            
55             Call this method from a controller action to set it up as a endpoint.
56            
57             =cut
58              
59             sub xmlrpc {
60 2     2 1 282     my $c = shift;
61              
62             # Deserialize
63 2         18     my $req;
64 2         20     eval { $req = $c->_deserialize_xmlrpc };
  2         34  
65 2 50 33     98     if ( $@ || !$req ) {
66 0 0       0         $c->log->debug(qq/Invalid XMLRPC request "$@"/) if $c->debug;
67 0         0         $c->_serialize_xmlrpc( RPC::XML::fault->new( -1, 'Invalid request' ) );
68 0         0         return 0;
69                 }
70              
71 2         33     my $res = RPC::XML::fault->new( -2, "No response for request" );
72              
73             # We have a method
74 2         404     my $method = $req->{method};
75 2 50       60     $c->log->debug(qq/XMLRPC request for "$method"/) if $c->debug;
76              
77 2 50       34     if ($method) {
78              
79 2         17         my $container;
80 2         17         for my $type ( @{ $c->dispatcher->dispatch_types } ) {
  2         28  
81 10 100       376             $container = $type
82                           if $type->isa('Catalyst::Plugin::XMLRPC::DispatchType::XMLRPC');
83                     }
84              
85 2 50       35         if ($container) {
86 2 50       25             if ( my $action = $container->{methods}{$method} ) {
87 2         46                 my $class = $action->class;
88 2   33     50                 $class = $c->components->{$class} || $class;
89 2         57                 my @args = @{ $c->req->args };
  2         72  
90 2         25                 $c->req->args( $req->{args} );
91 2         39                 $c->state( $c->execute( $class, $action ) );
92 2         24                 $res = $c->state;
93 2         53                 $c->req->args( \@args );
94                         }
95 0         0             else { RPC::XML::fault->new( -4, "Unknown method" ) }
96                     }
97 0         0         else { $res = RPC::XML::fault->new( -3, "Please come back later" ) }
98              
99                 }
100              
101             # Serialize response
102 2         37     $c->_serialize_xmlrpc($res);
103 2         211     return $res;
104             }
105              
106             =head2 setup_dispatcher
107            
108             =cut
109              
110             # Register our DispatchType
111             sub setup_dispatcher {
112 1     1 1 10     my $c = shift;
113 1         21     $c->NEXT::setup_dispatcher(@_);
114 1         11     push @{ $c->dispatcher->preload_dispatch_types },
  1         13  
115                   '+Catalyst::Plugin::XMLRPC::DispatchType::XMLRPC';
116 1         11     return $c;
117             }
118              
119             # Deserializes the xml in $c->req->body
120             sub _deserialize_xmlrpc {
121 2     2   20     my $c = shift;
122              
123 2         33     my $p = $c->_xmlrpc_parser->parse;
124 2         7437     my $body = $c->req->body;
125 2         149     my $content = do { local $/; <$body> };
  2         23  
  2         100  
126 2         25     $p->parse_more($content);
127 2         727     my $req = $p->parse_done;
128              
129 2         208     my $name = $req->name;
130 2         36     my @args = map { $_->value } @{ $req->args };
  3         124  
  2         23  
131              
132 2         22     return { method => $name, args => \@args };
133             }
134              
135             # Serializes the response to $c->res->body
136             sub _serialize_xmlrpc {
137 2     2   21     my ( $c, $status ) = @_;
138 2         36     my $res = RPC::XML::response->new($status);
139 2         274     $c->res->content_type('text/xml');
140 2         253     $c->res->body( $res->as_string );
141             }
142              
143             =back
144            
145             =head1 SEE ALSO
146            
147             L<Catalyst::Manual>, L<Catalyst::Test>, L<Catalyst::Request>,
148             L<Catalyst::Response>, L<Catalyst::Helper>, L<RPC::XML>
149            
150             =head1 AUTHOR
151            
152             Sebastian Riedel, C<sri@oook.de>
153             Marcus Ramberg, C<mramberg@cpan.org>
154             Christian Hansen
155             Yoshinori Sano
156             Michiel Ootjers
157             Jos Boumans
158            
159             =head1 LICENSE
160            
161             This library is free software, you can redistribute it and/or modify
162             it under the same terms as Perl itself.
163            
164             =cut
165              
166             1;
167