XML::RPC - Pure Perl implementation for an XML-RPC client and server.

    use XML::RPC;

    my $xmlrpc = XML::RPC->new('http://betty.userland.com/RPC2');
    my $result = $xmlrpc->call( 'examples.getStateStruct', { state1 => 12, state2 => 28 } );

    use XML::RPC;
    use CGI;

    my $q      = new CGI;
    my $xmlrpc = XML::RPC->new();
    my $xml    = $q->param('POSTDATA');

    print $q->header( -type => 'text/xml', -charset => 'UTF-8' );
    print $xmlrpc->receive( $xml, \&handler );

    sub handler {
        my ( $methodname, @params ) = @_;
        return { you_called => $methodname, with_params => \@params };
    }

package XML::RPC;

use strict;
use XML::TreePP;
use vars qw($VERSION $faultCode);
no strict 'refs';

$VERSION   = 0.9;
$faultCode = 0;

sub new {
    my $package = shift;
    my $self    = {};
    bless $self, $package;
    $self->{url} = shift;
    $self->{tpp} = XML::TreePP->new(@_);
    return $self;
}

sub call {
    my $self = shift;
    my ( $methodname, @params ) = @_;

    die 'no url' if ( !$self->{url} );

    $faultCode = 0;
    my $xml_out = $self->create_call_xml( $methodname, @params );

    $self->{xml_out} = $xml_out;

    my ( $result, $xml_in ) = $self->{tpp}->parsehttp(
        POST => $self->{url},
        $xml_out,
        {
            'Content-Type'   => 'text/xml',
            'User-Agent'     => 'XML-RPC/' . $VERSION,
            'Content-Length' => length($xml_out)
        }
    );

    $self->{xml_in} = $xml_in;

    my @data = $self->unparse_response($result);
    return @data == 1 ? $data[0] : @data;
}

sub receive {
    my $self   = shift;
    my $result = eval {
        my $xml_in = shift || die 'no xml';
        $self->{xml_in} = $xml_in;
        my $handler = shift || die 'no handler';
        my $hash = $self->{tpp}->parse($xml_in);
        my ( $methodname, @params ) = $self->unparse_call($hash);
        $self->create_response_xml( $handler->( $methodname, @params ) );
    };

    $result = $self->create_fault_xml($@) if ($@);
    $self->{xml_out} = $result;
    return $result;

}

sub create_fault_xml {
    my $self  = shift;
    my $error = shift;
    chomp($error);
    return $self->{tpp}
      ->write( { methodResponse => { fault => $self->parse( { faultString => $error, faultCode => int($faultCode) } ) } } );
}

sub create_call_xml {
    my $self = shift;
    my ( $methodname, @params ) = @_;

    return $self->{tpp}->write(
        {
            methodCall => {
                methodName => $methodname,
                params     => { param => [ map { $self->parse($_) } @params ] }
            }
        }
    );
}

sub create_response_xml {
    my $self   = shift;
    my @params = @_;

    return $self->{tpp}->write( { methodResponse => { params => { param => [ map { $self->parse($_) } @params ] } } } );
}

sub parse {
    my $self = shift;
    my $p    = shift;
    my $result;

    if ( ref($p) eq 'HASH' ) {
        $result = $self->parse_struct($p);
    }
    elsif ( ref($p) eq 'ARRAY' ) {
        $result = $self->parse_array($p);
    }
    elsif ( ref($p) eq 'CODE' ) {
        $result = $p->();
    }
    else {
        $result = $self->parse_scalar($p);
    }

    return { value => $result };
}

sub parse_scalar {
    my $self   = shift;
    my $scalar = shift;
    local $^W = undef;

    if (   ( $scalar =~ m/^[\-+]?\d+$/ )
        && ( abs($scalar) <= ( 0xffffffff >> 1 ) ) )
    {
        return { i4 => $scalar };
    }
    elsif ( $scalar =~ m/^[\-+]?\d+\.\d+$/ ) {
        return { double => $scalar };
    }
    else {
        return { string => \$scalar };
    }
}

sub parse_struct {
    my $self = shift;
    my $hash = shift;

    return { struct => { member => [ map { { name => $_, %{ $self->parse( $hash->{$_} ) } } } keys(%$hash) ] } };
}

sub parse_array {
    my $self  = shift;
    my $array = shift;

    return { array => { data => { value => [ map { $self->parse($_)->{value} } $self->list($array) ] } } };
}

sub unparse_response {
    my $self = shift;
    my $hash = shift;

    my $response = $hash->{methodResponse} || die 'no data';

    if ( $response->{fault} ) {
        return $self->unparse_value( $response->{fault}->{value} );
    }
    else {
        return map { $self->unparse_value( $_->{value} ) } $self->list( $response->{params}->{param} );
    }
}

sub unparse_call {
    my $self = shift;
    my $hash = shift;

    my $response = $hash->{methodCall} || die 'no data';

    my $methodname = $response->{methodName};
    my @args =
      map { $self->unparse_value( $_->{value} ) } $self->list( $response->{params}->{param} );
    return ( $methodname, @args );
}

sub unparse_value {
    my $self  = shift;
    my $value = shift;
    my $result;

    return $value if ( ref($value) ne 'HASH' );    # for unspecified params
    if ( $value->{struct} ) {
        $result = $self->unparse_struct( $value->{struct} );
        return !%$result
          ? undef
          : $result;                               # fix for empty hashrefs from XML::TreePP
    }
    elsif ( $value->{array} ) {
        return $self->unparse_array( $value->{array} );
    }
    else {
        return $self->unparse_scalar($value);
    }
}

sub unparse_scalar {
    my $self     = shift;
    my $scalar   = shift;
    my ($result) = values(%$scalar);
    return ( ref($result) eq 'HASH' && !%$result )
      ? undef
      : $result;    # fix for empty hashrefs from XML::TreePP
}

sub unparse_struct {
    my $self   = shift;
    my $struct = shift;

    return { map { $_->{name} => $self->unparse_value( $_->{value} ) } $self->list( $struct->{member} ) };
}

sub unparse_array {
    my $self  = shift;
    my $array = shift;
    my $data  = $array->{data};

    return [ map { $self->unparse_value($_) } $self->list( $data->{value} ) ];
}

sub list {
    my $self  = shift;
    my $param = shift;
    return () if ( !$param );
    return @$param if ( ref($param) eq 'ARRAY' );
    return ($param);
}

sub xml_in { shift->{xml_in} }

sub xml_out { shift->{xml_out} }

1;