# XML::RPC::Fast # # Copyright (c) 2008-2009 Mons Anderson , all rights reserved # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package XML::RPC::Fast; =head1 NAME XML::RPC::Fast - Fast and modular implementation for an XML-RPC client and server =cut our $VERSION = '0.8'; $VERSION = eval $VERSION; =head1 SYNOPSIS Generic usage use XML::RPC::Fast; my $server = XML::RPC::Fast->new( undef, %args ); my $client = XML::RPC::Fast->new( $uri, %args ); Create a simple XML-RPC service: use XML::RPC::Fast; my $rpc = XML::RPC::Fast->new( undef, # the url is not required by server external_encoding => 'koi8-r', # any encoding, accepted by Encode #internal_encoding => 'koi8-r', # not supported for now ); my $xml = do { local $/; }; length($xml) == $ENV{CONTENT_LENGTH} or warn "Content-Length differs from actually received"; print "Content-type: text/xml; charset=$rpc->{external_encoding}\n\n"; print $rpc->receive( $xml, sub { my ( $methodname, @params ) = @_; return { you_called => $methodname, with_params => \@params }; } ); Make a call to an XML-RPC service: use XML::RPC::Fast; my $rpc = XML::RPC::Fast->new( 'http://your.hostname/rpc/url' ); # Syncronous call my @result = $rpc->req( call => [ 'examples.getStateStruct', { state1 => 12, state2 => 28 } ], url => 'http://...', ); # Syncronous call (compatibility method) my @result = $rpc->call( 'examples.getStateStruct', { state1 => 12, state2 => 28 } ); # Syncronous or asyncronous call $rpc->req( call => ['examples.getStateStruct', { state1 => 12, state2 => 28 }], cb => sub { my @result = @_; }, ); # Syncronous or asyncronous call (compatibility method) $rpc->call( sub { my @result = @_; }, 'examples.getStateStruct', { state1 => 12, state2 => 28 } ); =head1 DESCRIPTION XML::RPC::Fast is format-compatible with XML::RPC, but may use different encoders to parse/compose xml. Curerntly included encoder uses L, and is 3 times faster than XML::RPC and 75% faster, than XML::Parser implementation =head1 METHODS =head2 new ($url, %args) Create XML::RPC::Fast object, server if url is undef, client if url is defined =head2 req( %ARGS ) Clientside. Make syncronous or asyncronous call (depends on UA). If have cb, will invoke $cb with results and should not croak If have no cb, will return results and croak on error (only syncronous UA) Arguments are =over 4 =item call => [ methodName => @args ] array ref of call arguments. Required =item cb => $cb->(@results) Invocation callback. Optional for syncronous UA. Behaviour is same as in call with C<$cb> and without =item url => $request_url Alternative invocation URL. Optional. By default will be used defined from constructor =item headers => { http-headers hashref } Additional http headers to request =item external_encoding => '..., Specify the encoding, used inside XML container just for this request. Passed to encoder =back =head2 call( 'method_name', @arguments ) : @results Clientside. Make syncronous call and return results. Croaks on error. Just a simple wrapper around C =head2 call( $cb->(@res), 'method_name', @arguments ): void Clientside. Make syncronous or asyncronous call (depends on UA) and invoke $cb with results. Should not croak. Just a simple wrapper around C =head2 receive ( $xml, $handler->($methodName,@args) ) : xml byte-stream Serverside. Process received XML and invoke $handler with parameters $methodName and @args and returns response XML On error conditions C<$handler> could set C<$XML::RPC::Fast::faultCode> and die, or return C ->receive( $xml, sub { # ... return rpcfault( 3, "Some error" ) if $error_condition $XML::RPC::Fast::faultCode = 4 and die "Another error" if $another_error_condition; return { call => $methodname, params => \@params }; }) =head2 registerType Proxy-method to encoder. See L =head2 registerClass Proxy-method to encoder. See L =head1 OPTIONS Below is the options, accepted by new() =head2 ua Client only. Useragent object, or package name ->new( $url, ua => 'LWP' ) # same as XML::RPC::UA::LWP # or ->new( $url, ua => 'XML::RPC::UA::LWP' ) # or ->new( $url, ua => XML::RPC::UA::LWP->new( ... ) ) # or ->new( $url, ua => XML::RPC::UA::Curl->new( ... ) ) =head2 timeout Client only. Timeout for calls. Passed directly to UA ->new( $url, ua => 'LWP', timeout => 10 ) =head2 useragent Client only. Useragent string. Passed directly to UA ->new( $url, ua => 'LWP', useragent => 'YourClient/1.11' ) =head2 encoder Client and server. Encoder object or package name ->new( $url, encoder => 'LibXML' ) # or ->new( $url, encoder => 'XML::RPC::Enc::LibXML' ) # or ->new( $url, encoder => XML::RPC::Enc::LibXML->new( ... ) ) =head2 internal_encoding B Specify the encoding you are using in your code. By default option is undef, which means flagged utf-8 For translations is used Encode, so the list of accepted encodings fully derived from it. =head2 external_encoding Specify the encoding, used inside XML container. By default it's utf-8. Passed directly to encoder ->new( $url, encoder => 'LibXML', external_encoding => 'koi8-r' ) =head1 ACCESSORS =head2 url Get or set client url =head2 encoder Direct access to encoder object =head2 ua Direct access to useragent object =head1 FUNCTIONS =head2 rpcfault(faultCode, faultString) Returns hash structure, that may be returned by serverside handler, instead of die. Not exported by default =head1 CUSTOM TYPES =head2 sub {{ 'base64' => encode_base64($data) }} When passing a CODEREF as a value, encoder will simply use the returned hashref as a type => value pair. =head2 bless( do{\(my $o = encode_base64('test') )}, 'base64' ) When passing SCALARREF as a value, package name will be taken as type and dereference as a value =head2 bless( do{\(my $o = { something =>'complex' } )}, 'base64' ) When passing REFREF as a value, package name will be taken as type and LC<::hash2xml(deref)> would be used as value =head2 customtype( $type, $data ) Easily compose SCALARREF based custom type =cut use 5.008003; # I want Encode to work use strict; use warnings; #use Time::HiRes qw(time); use Carp qw(carp croak); BEGIN { eval { require Sub::Name; Sub::Name->import('subname'); 1 } or do { *subname = sub { $_[1] } }; no strict 'refs'; for my $m (qw(url encoder ua)) { *$m = sub { local *__ANON__ = $m; my $self = shift; $self->{$m} = shift if @_; $self->{$m}; }; } } our $faultCode = 0; #sub encoder { shift->{encoder} } #sub ua { shift->{ua} } sub import { my $me = shift; my $pkg = caller; no strict 'refs'; @_ or return; for (@_) { if ( $_ eq 'rpcfault' or $_ eq 'customtype') { *{$pkg.'::'.$_} = \&$_; } else { croak "$_ is not exported by $me"; } } } sub rpcfault($$) { my ($code,$string) = @_; return { fault => { faultCode => $code, faultString => $string, }, } } sub customtype($$) { my $type = shift; my $data = shift; bless( do{\(my $o = $data )}, $type ) } sub _load { my $pkg = shift; my ($prefix,$req,$default,@args) = @_; if (defined $req) { my @fail; eval { require join '/', split '::', $prefix.$req.'.pm'; $req = $prefix.$req; 1; } or do { push @fail, [ $prefix.$req,$@ ]; eval{ require join '/', split '::', $req.'.pm'; 1 } } or do { push @fail, [ $req,$@ ]; croak "Can't load any of:\n".join("\n\t",map { "$$_[0]: $$_[1]" } @fail)."\n"; } } else { eval { $req = $prefix.$default; require join '/', split '::', $req.'.pm'; 1 } or do { croak "Can't load $req: $@\n"; } } return $req->new(@args); } sub new { my $package = shift; my $url = shift; local $SIG{__WARN__} = sub { local $_ = shift; s{\n$}{};carp $_ }; my $self = { @_, }; unless ( ref $self->{encoder} ) { $self->{encoder} = $package->_load( 'XML::RPC::Enc::', $self->{encoder}, 'LibXML', internal_encoding => $self->{internal_encoding}, external_encoding => $self->{external_encoding}, ); } if ( $url and !ref $self->{ua} ) { $self->{ua} = $package->_load( 'XML::RPC::UA::', $self->{ua}, 'LWP', ua => $self->{useragent} || 'XML-RPC-Fast/'.$VERSION, timeout => $self->{timeout}, ); } $self->{url} = $url; bless $self, $package; return $self; } sub registerType { shift->encoder->registerType(@_); } sub registerClass { shift->encoder->registerClass(@_); } sub call { my $self = shift; my $cb;$cb = shift if ref $_[0] and ref $_[0] eq 'CODE'; $self->req( call => [@_], $cb ? ( cb => $cb ) : (), ); } sub req { my $self = shift; my %args = @_; my $cb = $args{cb}; if ($self->ua->async and !$cb) { croak("Call have no cb and useragent is async"); } my ( $methodname, @params ) = @{ $args{call} }; my $url = $args{url} || $self->{url}; unless ( $url ) { if ($cb) { $cb->(rpcfault(500, "No url")); return; } else { croak('No url'); } }; my $uri = "$url#$methodname"; $faultCode = 0; my $body; { local $self->encoder->{external_encoding} = $args{external_encoding} if exists $args{external_encoding}; my $newurl; ($body,$newurl) = $self->encoder->request( $methodname, @params ); $url = $newurl if defined $newurl; } $self->{xml_out} = $body; #my $start = time; my @data; #warn "Call $body"; $self->ua->call( ($args{method} || 'POST') => $url, $args{headers} ? ( headers => $args{headers} ) : (), body => $body, cb => sub { my $res = shift; { ( my $status = $res->status_line )=~ s/:?\s*$//s; $res->code == 200 or @data = (rpcfault( $res->code, "Call to $uri failed: $status" )) and last; my $text = $res->content; length($text) and $text =~ /^\s*<\?xml/s or @data = ({fault=>{ faultCode => 499, faultString => "Call to $uri failed: Response is not an XML: \"$text\"" }}) and last; eval { $self->{xml_in} = $text; @data = $self->encoder->decode( $text ); 1; } or @data = ({fault=>{ faultCode => 499, faultString => "Call to $uri failed: Bad Response: $@, \"$text\"" }}) and last; } #warn "Have data @data"; if ($cb) {{ local $faultCode = $data[0]{fault}{faultCode} if ref $data[0] eq 'HASH' and exists $data[0]{fault}; $cb->(@data); return; }} }, ); $cb and defined wantarray and carp "Useless use of return value for ".__PACKAGE__."->call(cb)"; return if $cb; if ( ref $data[0] eq 'HASH' and exists $data[0]{fault} ) { $faultCode = $data[0]{fault}{faultCode}; croak( "Remote Error [$data[0]{fault}{faultCode}]: ".$data[0]{fault}{faultString} ); } return @data == 1 ? $data[0] : @data; } sub receive { # ok my $self = shift; my $result = eval { my $xml_in = shift or return $self->encoder->fault(400,"Bad Request: No XML"); my $handler = shift or return $self->encoder->fault(501,"Server Error: No handler");; my ( $methodname, @params ) = $self->encoder->decode($xml_in); local $self->{xml_in} = $xml_in; subname( 'receive.handler.'.$methodname,$handler ); my @res = $handler->( $methodname, @params ); if (ref $res[0] eq 'HASH' and exists $res[0]{fault}) { $self->encoder->fault( $res[0]{fault}{faultCode},$res[0]{fault}{faultString} ); } else { $self->encoder->response( @res ); } }; if ($@) { (my $e = "$@") =~ s{\r?\n+$}{}s; $result = $self->encoder->fault(defined $faultCode ? $faultCode : 500,$e); } return $result; } =head1 BUGS & SUPPORT Bugs reports and testcases are welcome. It you write your own Enc or UA, I may include it into distribution If you have propositions for default custom types (see Enc), send me patches See L to report and view bugs. =head1 AUTHOR Mons Anderson, C<< >> =head1 COPYRIGHT & LICENSE Copyright (c) 2008-2009 Mons Anderson. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1;