1# XML::RPC::Fast
2#
3# Copyright (c) 2008-2009 Mons Anderson <mons@cpan.org>, all rights reserved
4# This program is free software; you can redistribute it and/or
5# modify it under the same terms as Perl itself.
6
7package XML::RPC::Fast;
8
9=head1 NAME
10
11XML::RPC::Fast - Fast and modular implementation for an XML-RPC client and server
12
13=cut
14
15our $VERSION   = '0.8'; $VERSION = eval $VERSION;
16
17=head1 SYNOPSIS
18
19Generic usage
20
21    use XML::RPC::Fast;
22
23    my $server = XML::RPC::Fast->new( undef, %args );
24    my $client = XML::RPC::Fast->new( $uri,  %args );
25
26Create a simple XML-RPC service:
27
28    use XML::RPC::Fast;
29
30    my $rpc = XML::RPC::Fast->new(
31        undef,                         # the url is not required by server
32        external_encoding => 'koi8-r', # any encoding, accepted by Encode
33        #internal_encoding => 'koi8-r', # not supported for now
34    );
35    my $xml = do { local $/; <STDIN> };
36    length($xml) == $ENV{CONTENT_LENGTH} or warn "Content-Length differs from actually received";
37
38    print "Content-type: text/xml; charset=$rpc->{external_encoding}\n\n";
39    print $rpc->receive( $xml, sub {
40        my ( $methodname, @params ) = @_;
41        return { you_called => $methodname, with_params => \@params };
42    } );
43
44Make a call to an XML-RPC service:
45
46    use XML::RPC::Fast;
47
48    my $rpc = XML::RPC::Fast->new(
49        'http://your.hostname/rpc/url'
50    );
51
52    # Syncronous call
53    my @result = $rpc->req(
54        call => [ 'examples.getStateStruct', { state1 => 12, state2 => 28 } ],
55        url => 'http://...',
56    );
57
58    # Syncronous call (compatibility method)
59    my @result = $rpc->call( 'examples.getStateStruct', { state1 => 12, state2 => 28 } );
60
61    # Syncronous or asyncronous call
62    $rpc->req(
63        call => ['examples.getStateStruct', { state1 => 12, state2 => 28 }],
64        cb   => sub {
65            my @result = @_;
66        },
67    );
68
69    # Syncronous or asyncronous call (compatibility method)
70    $rpc->call( sub {
71        my @result = @_;
72
73    }, 'examples.getStateStruct', { state1 => 12, state2 => 28 } );
74
75
76=head1 DESCRIPTION
77
78XML::RPC::Fast is format-compatible with XML::RPC, but may use different encoders to parse/compose xml.
79Curerntly included encoder uses L<XML::LibXML>, and is 3 times faster than XML::RPC and 75% faster, than XML::Parser implementation
80
81=head1 METHODS
82
83=head2 new ($url, %args)
84
85Create XML::RPC::Fast object, server if url is undef, client if url is defined
86
87=head2 req( %ARGS )
88
89Clientside. Make syncronous or asyncronous call (depends on UA).
90
91If have cb, will invoke $cb with results and should not croak
92
93If have no cb, will return results and croak on error (only syncronous UA)
94
95Arguments are
96
97=over 4
98
99=item call => [ methodName => @args ]
100
101array ref of call arguments. Required
102
103=item cb => $cb->(@results)
104
105Invocation callback. Optional for syncronous UA. Behaviour is same as in call with C<$cb> and without
106
107=item url => $request_url
108
109Alternative invocation URL. Optional. By default will be used defined from constructor
110
111=item headers => { http-headers hashref }
112
113Additional http headers to request
114
115=item external_encoding => '...,
116
117Specify the encoding, used inside XML container just for this request. Passed to encoder
118
119=back
120
121=head2 call( 'method_name', @arguments ) : @results
122
123Clientside. Make syncronous call and return results. Croaks on error. Just a simple wrapper around C<req>
124
125=head2 call( $cb->(@res), 'method_name', @arguments ): void
126
127Clientside. Make syncronous or asyncronous call (depends on UA) and invoke $cb with results. Should not croak. Just a simple wrapper around C<req>
128
129=head2 receive ( $xml, $handler->($methodName,@args) ) : xml byte-stream
130
131Serverside. Process received XML and invoke $handler with parameters $methodName and @args and returns response XML
132
133On error conditions C<$handler> could set C<$XML::RPC::Fast::faultCode> and die, or return C<rpcfault($faultCode,$faultString)>
134
135    ->receive( $xml, sub {
136        # ...
137        return rpcfault( 3, "Some error" ) if $error_condition
138        $XML::RPC::Fast::faultCode = 4 and die "Another error" if $another_error_condition;
139
140        return { call => $methodname, params => \@params };
141    })
142
143=head2 registerType
144
145Proxy-method to encoder. See L<XML::RPC::Enc>
146
147=head2 registerClass
148
149Proxy-method to encoder. See L<XML::RPC::Enc>
150
151=head1 OPTIONS
152
153Below is the options, accepted by new()
154
155=head2 ua
156
157Client only. Useragent object, or package name
158
159    ->new( $url, ua => 'LWP' ) # same as XML::RPC::UA::LWP
160    # or
161    ->new( $url, ua => 'XML::RPC::UA::LWP' )
162    # or
163    ->new( $url, ua => XML::RPC::UA::LWP->new( ... ) )
164    # or
165    ->new( $url, ua => XML::RPC::UA::Curl->new( ... ) )
166
167=head2 timeout
168
169Client only. Timeout for calls. Passed directly to UA
170
171    ->new( $url, ua => 'LWP', timeout => 10 )
172
173=head2 useragent
174
175Client only. Useragent string. Passed directly to UA
176
177    ->new( $url, ua => 'LWP', useragent => 'YourClient/1.11' )
178
179=head2 encoder
180
181Client and server. Encoder object or package name
182
183    ->new( $url, encoder => 'LibXML' )
184    # or
185    ->new( $url, encoder => 'XML::RPC::Enc::LibXML' )
186    # or
187    ->new( $url, encoder => XML::RPC::Enc::LibXML->new( ... ) )
188
189=head2 internal_encoding B<NOT IMPLEMENTED YET>
190
191Specify the encoding you are using in your code. By default option is undef, which means flagged utf-8
192For translations is used Encode, so the list of accepted encodings fully derived from it.
193
194=head2 external_encoding
195
196Specify the encoding, used inside XML container. By default it's utf-8. Passed directly to encoder
197
198    ->new( $url, encoder => 'LibXML', external_encoding => 'koi8-r' )
199
200=head1 ACCESSORS
201
202=head2 url
203
204Get or set client url
205
206=head2 encoder
207
208Direct access to encoder object
209
210=head2 ua
211
212Direct access to useragent object
213
214=head1 FUNCTIONS
215
216=head2 rpcfault(faultCode, faultString)
217
218Returns hash structure, that may be returned by serverside handler, instead of die. Not exported by default
219
220=head1 CUSTOM TYPES
221
222=head2 sub {{ 'base64' => encode_base64($data) }}
223
224When passing a CODEREF as a value, encoder will simply use the returned hashref as a type => value pair.
225
226=head2 bless( do{\(my $o = encode_base64('test') )}, 'base64' )
227
228When passing SCALARREF as a value, package name will be taken as type and dereference as a value
229
230=head2 bless( do{\(my $o = { something =>'complex' } )}, 'base64' )
231
232When passing REFREF as a value, package name will be taken as type and L<XML::Hash::LX>C<::hash2xml(deref)> would be used as value
233
234=head2 customtype( $type, $data )
235
236Easily compose SCALARREF based custom type
237
238=cut
239
240use 5.008003; # I want Encode to work
241use strict;
242use warnings;
243
244#use Time::HiRes qw(time);
245use Carp qw(carp croak);
246
247BEGIN {
248	eval {
249		require Sub::Name;
250		Sub::Name->import('subname');
251	1 } or do { *subname = sub { $_[1] } };
252
253	no strict 'refs';
254	for my $m (qw(url encoder ua)) {
255		*$m = sub {
256			local *__ANON__ = $m;
257			my $self = shift;
258			$self->{$m} = shift if @_;
259			$self->{$m};
260		};
261	}
262}
263
264our $faultCode = 0;
265
266#sub encoder { shift->{encoder} }
267#sub ua      { shift->{ua} }
268
269sub import {
270	my $me = shift;
271	my $pkg = caller;
272	no strict 'refs';
273	@_ or return;
274	for (@_) {
275		if ( $_ eq 'rpcfault' or $_ eq 'customtype') {
276			*{$pkg.'::'.$_} = \&$_;
277		} else {
278			croak "$_ is not exported by $me";
279		}
280	}
281}
282
283sub rpcfault($$) {
284	my ($code,$string) = @_;
285	return {
286		fault => {
287			faultCode   => $code,
288			faultString => $string,
289		},
290	}
291}
292sub customtype($$) {
293	my $type = shift;
294	my $data = shift;
295	bless( do{\(my $o = $data )}, $type )
296}
297
298sub _load {
299	my $pkg = shift;
300	my ($prefix,$req,$default,@args) = @_;
301	if (defined $req) {
302		my @fail;
303		eval {
304			require join '/', split '::', $prefix.$req.'.pm';
305			$req = $prefix.$req;
306			1;
307		}
308		or do {
309			push @fail, [ $prefix.$req,$@ ];
310			eval{ require join '/', split '::', $req.'.pm'; 1 }
311		}
312		or do {
313			push @fail, [ $req,$@ ];
314			croak "Can't load any of:\n".join("\n\t",map { "$$_[0]: $$_[1]" } @fail)."\n";
315		}
316	} else {
317		eval {
318			$req = $prefix.$default;
319			require join '/', split '::', $req.'.pm'; 1
320		}
321		or do {
322			croak "Can't load $req: $@\n";
323		}
324	}
325	return $req->new(@args);
326}
327
328sub new {
329	my $package = shift;
330	my $url  = shift;
331	local $SIG{__WARN__} = sub { local $_ = shift; s{\n$}{};carp $_ };
332	my $self = {
333		@_,
334	};
335	unless ( ref $self->{encoder} ) {
336		$self->{encoder} = $package->_load(
337			'XML::RPC::Enc::', $self->{encoder}, 'LibXML',
338			internal_encoding => $self->{internal_encoding},
339			external_encoding => $self->{external_encoding},
340		);
341	}
342	if ( $url and !ref $self->{ua} ) {
343		$self->{ua} = $package->_load(
344			'XML::RPC::UA::', $self->{ua}, 'LWP',
345			ua      => $self->{useragent} || 'XML-RPC-Fast/'.$VERSION,
346			timeout => $self->{timeout},
347		);
348	}
349	$self->{url} = $url;
350	bless $self, $package;
351	return $self;
352}
353
354sub registerType {
355	shift->encoder->registerType(@_);
356}
357
358sub registerClass {
359	shift->encoder->registerClass(@_);
360}
361
362sub call {
363	my $self = shift;
364	my $cb;$cb = shift if ref $_[0] and ref $_[0] eq 'CODE';
365	$self->req(
366		call => [@_],
367		$cb ? ( cb => $cb ) : (),
368	);
369}
370
371sub req {
372	my $self = shift;
373	my %args = @_;
374	my $cb = $args{cb};
375	if ($self->ua->async and !$cb) {
376		croak("Call have no cb and useragent is async");
377	}
378	my ( $methodname, @params ) = @{ $args{call} };
379	my $url = $args{url} || $self->{url};
380
381	unless ( $url ) {
382		if ($cb) {
383			$cb->(rpcfault(500, "No url"));
384			return;
385		} else {
386			croak('No url');
387		}
388	};
389	my $uri = "$url#$methodname";
390
391	$faultCode = 0;
392	my $body;
393	{
394		local $self->encoder->{external_encoding} = $args{external_encoding} if exists $args{external_encoding};
395		my $newurl;
396		($body,$newurl) = $self->encoder->request( $methodname, @params );
397		$url = $newurl if defined $newurl;
398	}
399
400	$self->{xml_out} = $body;
401
402	#my $start = time;
403	my @data;
404	#warn "Call $body";
405	$self->ua->call(
406		($args{method} || 'POST')    => $url,
407		$args{headers} ? ( headers => $args{headers} ) : (),
408		body    => $body,
409		cb      => sub {
410			my $res = shift;
411			{
412				( my $status = $res->status_line )=~ s/:?\s*$//s;
413				$res->code == 200 or @data =
414					(rpcfault( $res->code, "Call to $uri failed: $status" ))
415					and last;
416				my $text = $res->content;
417				length($text) and $text =~ /^\s*<\?xml/s or @data =
418					({fault=>{ faultCode => 499,        faultString => "Call to $uri failed: Response is not an XML: \"$text\"" }})
419					and last;
420				eval {
421					$self->{xml_in} = $text;
422					@data = $self->encoder->decode( $text );
423					1;
424				} or @data =
425					({fault=>{ faultCode => 499,     faultString => "Call to $uri failed: Bad Response: $@, \"$text\"" }})
426					and last;
427			}
428			#warn "Have data @data";
429			if ($cb) {{
430				local $faultCode = $data[0]{fault}{faultCode} if ref $data[0] eq 'HASH' and exists $data[0]{fault};
431				$cb->(@data);
432				return;
433			}}
434		},
435	);
436	$cb and defined wantarray and carp "Useless use of return value for ".__PACKAGE__."->call(cb)";
437	return if $cb;
438	if ( ref $data[0] eq 'HASH' and exists $data[0]{fault} ) {
439		$faultCode = $data[0]{fault}{faultCode};
440		croak( "Remote Error [$data[0]{fault}{faultCode}]: ".$data[0]{fault}{faultString} );
441	}
442	return @data == 1 ? $data[0] : @data;
443}
444
445sub receive { # ok
446	my $self   = shift;
447	my $result = eval {
448		my $xml_in = shift or return $self->encoder->fault(400,"Bad Request: No XML");
449		my $handler = shift or return $self->encoder->fault(501,"Server Error: No handler");;
450		my ( $methodname, @params ) = $self->encoder->decode($xml_in);
451		local $self->{xml_in} = $xml_in;
452		subname( 'receive.handler.'.$methodname,$handler );
453		my @res = $handler->( $methodname, @params );
454		if (ref $res[0] eq 'HASH' and exists $res[0]{fault}) {
455			$self->encoder->fault( $res[0]{fault}{faultCode},$res[0]{fault}{faultString} );
456		} else {
457			$self->encoder->response( @res );
458		}
459	};
460	if ($@) {
461		(my $e = "$@") =~ s{\r?\n+$}{}s;
462		$result = $self->encoder->fault(defined $faultCode ? $faultCode : 500,$e);
463	}
464	return $result;
465}
466
467=head1 BUGS & SUPPORT
468
469Bugs reports and testcases are welcome.
470
471It you write your own Enc or UA, I may include it into distribution
472
473If you have propositions for default custom types (see Enc), send me patches
474
475See L<http://rt.cpan.org> to report and view bugs.
476
477=head1 AUTHOR
478
479Mons Anderson, C<< <mons@cpan.org> >>
480
481=head1 COPYRIGHT & LICENSE
482
483Copyright (c) 2008-2009 Mons Anderson.
484
485This program is free software; you can redistribute it and/or modify it
486under the same terms as Perl itself.
487
488=cut
489
4901;
491