File Coverage

blib/lib/Catalyst/Plugin/XMLRPC.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


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