File Coverage

blib/lib/Protocol/XMLRPC/Client.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Protocol::XMLRPC::Client;

use strict;
use warnings;

use Protocol::XMLRPC::MethodCall;
use Protocol::XMLRPC::MethodResponse;

require Carp;

sub new {
    my $class = shift;

    my $self = {@_};
    bless $self, $class;

    Carp::croak('http_req_cb is required') unless $self->{http_req_cb};

    return $self;
}

sub http_req_cb {
    defined $_[1] ? $_[0]->{http_req_cb} = $_[1] : $_[0]->{http_req_cb};
}

sub call {
    my $self = shift;
    my ($url, $method_name, $args, $cb, $error_cb) = @_;

    if (!defined $cb) {
        ($cb, $args) = ($args, []);
    }
    elsif (ref($args) ne 'ARRAY' && !defined $error_cb) {
        ($cb, $error_cb, $args) = ($args, $cb, []);
    }

    my $method_call = Protocol::XMLRPC::MethodCall->new(name => $method_name);
    foreach my $arg (@$args) {
        $method_call->add_param($arg);
    }

    my $host = $url;
    $host =~ s|^http(s)?://||;
    $host =~ s|/.*$||;

    my $headers = {
        'Content-Type' => 'text/xml',
        'User-Agent'   => 'Protocol-XMLRPC (Perl)',
        'Host'         => $host
    };

    $self->http_req_cb->(
        $self, $url, 'POST', $headers, "$method_call" =>
          sub {
            my ($self, $status, $headers, $body) = @_;

            unless ($status && $status == 200) {
                return $error_cb ? $error_cb->($self) : $cb->($self);
            }

            my $res = Protocol::XMLRPC::MethodResponse->parse($body);

            return $cb->($self, $res) if $res;

            return $error_cb ? $error_cb->($self) : $cb->($self);
        }
    );
}

1;
__END__