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; |