1 |
jonen |
1.1 |
#!/usr/bin/perl |
2 |
|
|
## |
3 |
|
|
## POE::Component::RPCXML::Client -- XML-RPC Client Component |
4 |
|
|
## |
5 |
|
|
## $Id: Client.pm,v 1.2 2001/09/20 01:32:38 fletch Exp $ |
6 |
|
|
## |
7 |
|
|
package POE::Component::RPCXML::Client; |
8 |
|
|
|
9 |
|
|
use strict; |
10 |
|
|
|
11 |
|
|
use Carp qw( croak carp ); |
12 |
|
|
|
13 |
|
|
use POE qw( Kernel Session Component::Client::HTTP ); |
14 |
|
|
|
15 |
|
|
use HTTP::Request (); |
16 |
|
|
use HTTP::Response (); |
17 |
|
|
|
18 |
|
|
use RPC::XML (); |
19 |
|
|
use RPC::XML::Parser (); |
20 |
|
|
|
21 |
|
|
my %default_args = ( |
22 |
|
|
Debug => undef, |
23 |
|
|
Alias => 'rpcxml', |
24 |
|
|
); |
25 |
|
|
|
26 |
|
|
my $states = { |
27 |
|
|
_start => 'start', |
28 |
|
|
_stop => 'stop', |
29 |
|
|
_signal => 'signal', |
30 |
|
|
_default => 'default', |
31 |
|
|
call => 'call', |
32 |
|
|
response => 'response', |
33 |
|
|
}; |
34 |
|
|
|
35 |
|
|
sub new { |
36 |
|
|
my $class = shift; |
37 |
|
|
$class = ref( $class ) || $class; |
38 |
|
|
my( %args ) = ( %default_args, @_ ); |
39 |
|
|
|
40 |
|
|
my $self = bless {}, $class; |
41 |
|
|
|
42 |
|
|
croak "${class}::new: Missing required URL parameter\n" |
43 |
|
|
unless exists $args{ URL }; |
44 |
|
|
|
45 |
|
|
$self->{ _debug } = $args{ Debug }; |
46 |
|
|
$self->{ _url } = $args{ URL }; |
47 |
|
|
$self->{ _alias } = $args{ Alias }; |
48 |
|
|
$self->{ _ua_alias } = $args{ Alias } . '_ua'; |
49 |
|
|
|
50 |
|
|
$self->{ _request } = HTTP::Request->new( POST => $self->{_url} ); |
51 |
|
|
|
52 |
|
|
## Create a client to make HTTP requests |
53 |
|
|
POE::Component::Client::HTTP->spawn( Alias => $self->{_ua_alias} ); |
54 |
|
|
|
55 |
|
|
## See $states defined up above . . . |
56 |
|
|
POE::Session->create( object_states => [ $self => $states, ], ); |
57 |
|
|
|
58 |
|
|
return $self; |
59 |
|
|
} |
60 |
|
|
|
61 |
|
|
sub spawn { shift()->new( @_ ) } |
62 |
|
|
|
63 |
|
|
## |
64 |
|
|
## start -- Startup state |
65 |
|
|
## |
66 |
|
|
sub start { |
67 |
|
|
my( $self, $kernel, $heap, $session ) = |
68 |
|
|
@_[ OBJECT, KERNEL, HEAP, SESSION ]; |
69 |
|
|
|
70 |
|
|
## Just pipe up if we're debugging |
71 |
|
|
print STDERR "## ", __PACKAGE__, "::start\r\n" if $self->{_debug}; |
72 |
|
|
|
73 |
|
|
$kernel->alias_set( $self->{_alias} ); |
74 |
|
|
|
75 |
|
|
return |
76 |
|
|
} |
77 |
|
|
|
78 |
|
|
## |
79 |
|
|
## stop -- Shutdown state |
80 |
|
|
## |
81 |
|
|
sub stop { |
82 |
|
|
my( $self, $kernel, $heap ) = @_[ OBJECT, KERNEL, HEAP ]; |
83 |
|
|
|
84 |
|
|
## Just pipe up if we're debugging |
85 |
|
|
print STDERR "## ", __PACKAGE__, "::stop\r\n" if $self->{_debug}; |
86 |
|
|
|
87 |
|
|
return |
88 |
|
|
} |
89 |
|
|
|
90 |
|
|
## |
91 |
|
|
## signal -- Handle any signals received |
92 |
|
|
## |
93 |
|
|
sub signal { |
94 |
|
|
my( $self, $heap, $signal ) = @_[ OBJECT, HEAP, ARG0 ]; |
95 |
|
|
|
96 |
|
|
## Just pipe up if we're debugging |
97 |
|
|
print STDERR "## ", __PACKAGE__, "::signal $signal\n" if $self->{_debug}; |
98 |
|
|
|
99 |
|
|
return |
100 |
|
|
} |
101 |
|
|
|
102 |
|
|
## |
103 |
|
|
## default -- Catch any unhandled events for debugging |
104 |
|
|
## |
105 |
|
|
sub default { |
106 |
|
|
my( $self, $heap, $event ) = @_[ OBJECT, HEAP, ARG0 ]; |
107 |
|
|
|
108 |
|
|
## Just pipe up if we're debugging |
109 |
|
|
print STDERR "## ", __PACKAGE__, "::default got $event\n" |
110 |
|
|
if $self->{_debug}; |
111 |
|
|
|
112 |
|
|
return |
113 |
|
|
} |
114 |
|
|
|
115 |
|
|
sub call { |
116 |
|
|
my( $self, $kernel, $heap, $sender, $request, $target ) |
117 |
|
|
= @_[ OBJECT, KERNEL, HEAP, SENDER, ARG0..ARG1 ]; |
118 |
|
|
|
119 |
|
|
## Just pipe up if we're debugging |
120 |
|
|
print STDERR "## ", __PACKAGE__, |
121 |
|
|
"::call got $request from $sender:$target\n" |
122 |
|
|
if $self->{_debug}; |
123 |
|
|
|
124 |
|
|
## Remember what session and state this goes back to |
125 |
|
|
my $tag = $sender . ':' . $target; |
126 |
|
|
$heap->{ targets }->{$tag} = [ $sender, $target ]; |
127 |
|
|
|
128 |
|
|
print STDERR "## tag is $tag\n" if $self->{_debug}; |
129 |
|
|
|
130 |
|
|
my $req = $self->{_request}->clone; |
131 |
|
|
$req->content( $request->as_string ); |
132 |
|
|
$req->push_header( 'Content-Type' => 'text/xml' ); |
133 |
|
|
$req->push_header( 'Content-Length' => length $req->content ); |
134 |
|
|
|
135 |
|
|
$kernel->post( $self->{_ua_alias} => request |
136 |
|
|
=> response => $req => $tag ); |
137 |
|
|
|
138 |
|
|
return; |
139 |
|
|
} |
140 |
|
|
|
141 |
|
|
## |
142 |
|
|
## response -- Handle replies from calls |
143 |
|
|
## |
144 |
|
|
sub response { |
145 |
|
|
my( $self, $kernel, $heap, $req, $resp ) |
146 |
|
|
= @_[ OBJECT, KERNEL, HEAP, ARG0..ARG1 ]; |
147 |
|
|
|
148 |
|
|
my $tag = $req->[1]; |
149 |
|
|
my( $target_session, $target_state ) = @{ $heap->{targets}->{$tag} }; |
150 |
|
|
|
151 |
|
|
## Just pipe up if we're debugging |
152 |
|
|
print STDERR "## ", __PACKAGE__, "::response\n## tag $tag\n" |
153 |
|
|
if $self->{_debug}; |
154 |
|
|
|
155 |
|
|
my $xmlrep = RPC::XML::Parser->new( )->parse( $resp->[0]->content ); |
156 |
|
|
if( ref $xmlrep ) { |
157 |
|
|
$kernel->post( $target_session, $target_state, $xmlrep ); |
158 |
|
|
} else { |
159 |
|
|
warn "RPCXML Client error: $xmlrep\n"; |
160 |
|
|
} |
161 |
|
|
|
162 |
|
|
return |
163 |
|
|
} |
164 |
|
|
|
165 |
|
|
|
166 |
|
|
1; |
167 |
|
|
|
168 |
|
|
__END__ |
169 |
|
|
|
170 |
|
|
=pod |
171 |
|
|
|
172 |
|
|
=head1 NAME |
173 |
|
|
|
174 |
|
|
POE::Component::RPCXML::Client - POE RPCXML client |
175 |
|
|
|
176 |
|
|
=head1 SYNOPSIS |
177 |
|
|
|
178 |
|
|
use POE qw(Component::RPXML::Client); |
179 |
|
|
|
180 |
|
|
=head1 DESCRIPTION |
181 |
|
|
|
182 |
|
|
This module implements a xmlrpc client interface in POE. |
183 |
|
|
|
184 |
|
|
Like many POE modules, Client does not create an object when the new() |
185 |
|
|
method is called, instead a new POE session is started. |
186 |
|
|
|
187 |
|
|
=head2 CONSTRUCTOR |
188 |
|
|
|
189 |
|
|
To create a new RPCXML client session, make a call like this: |
190 |
|
|
|
191 |
|
|
POE::Component::RPCXML::Client->new( |
192 |
|
|
Alias => 'rpcxml', |
193 |
|
|
URL => $url, |
194 |
|
|
); |
195 |
|
|
|
196 |
|
|
The alias should specify the name of the alias for the session to |
197 |
|
|
created, and the URL should refer to the server this RPCXML client will |
198 |
|
|
connect to. |
199 |
|
|
|
200 |
|
|
=head1 MESSAGES |
201 |
|
|
|
202 |
|
|
=head2 call |
203 |
|
|
|
204 |
|
|
To call a procedure on the server, send the following message: |
205 |
|
|
|
206 |
|
|
$kernel->post('rpcxml', 'call', $xmlreq, 'response_state'); |
207 |
|
|
|
208 |
|
|
C<rpcxml> should be replaced with the actual alias used for the session, |
209 |
|
|
or a reference to the session. C<$xmlreq> should be a RPCXML request |
210 |
|
|
object created with RPC::XML::request->new. |
211 |
|
|
|
212 |
|
|
The response state should expect to receive the RPC::XML response object |
213 |
|
|
in C<ARG0>. |
214 |
|
|
|
215 |
|
|
=head1 AUTHOR |
216 |
|
|
|
217 |
|
|
Fletch E<lt>fletch@phydeaux.orgE<gt> |
218 |
|
|
|
219 |
|
|
=cut |