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