#
# BZ::Client::XMLRPC.pm - Performs XML-RPC calls on behalf of the client.
#

use strict;
use warnings "all";

package BZ::Client::XMLRPC;

use LWP();
use XML::Writer();
use BZ::Client::XMLRPC::Parser();

our $VERSION = 1.0;
our $counter;

sub new($%) {
    my $class = shift;
    my $self = { @_ };
    bless($self, ref($class) || $class);
    return $self;
}

sub url($;$) {
    my $self = shift;
    if (@_) {
        $self->{'url'} = shift;
    } else {
        return $self->{'url'};
    }
}

sub user_agent($;$) {
    my $self = shift;
    if (@_) {
        $self->{'user_agent'} = shift;
    } else {
        my $ua = $self->{'user_agent'};
        if (!defined($ua)) {
            $ua = LWP::UserAgent->new();
            $ua->agent("BZ::Client::XMLRPC $VERSION");
            $self->user_agent($ua);
        }
        return $ua;
    }
}

sub error($$;$$) {
    my($self, $message, $http_code, $xmlrpc_code) = @_;
    require BZ::Client::Exception;
    BZ::Client::Exception->throw("message" => $message,
                                 "http_code" => $http_code,
                                 "xmlrpc_code" => $xmlrpc_code);
}

sub value($$$) {
    my($self, $writer, $value) = @_;
    if (ref($value) eq "HASH") {
        $writer->startTag("value");
        $writer->startTag("struct");
        my ($key,$val);
        while (($key, $val) = each %$value) {
            $writer->startTag("member");
            $writer->startTag("name");
            $writer->characters($key);
            $writer->endTag("name");
            $self->value($writer, $val);
            $writer->endTag("member");
        }
        $writer->endTag("struct");
        $writer->endTag("value");
    } elsif (ref($value) eq "ARRAY") {
        $writer->startTag("value");
        $writer->startTag("array");
        $writer->startTag("data");
        foreach my $val (@$value) {
            $self->value($writer, $val);
        }
        $writer->endTag("data");
        $writer->endTag("array");
        $writer->endTag("value");
    } elsif (ref($value) eq "BZ::Client::XMLRPC::int") {
        $writer->startTag("value");
        $writer->startTag("i4");
        $writer->characters($$value);
        $writer->endTag("i4");
        $writer->endTag("value");
    } elsif (ref($value) eq "BZ::Client::XMLRPC::boolean") {
        $writer->startTag("value");
        $writer->startTag("boolean");
        $writer->characters($$value ? "1" : "0");
        $writer->endTag("boolean");
        $writer->endTag("value");
    } elsif (ref($value) eq "BZ::Client::XMLRPC::double") {
        $writer->startTag("value");
        $writer->startTag("double");
        $writer->characters($$value);
        $writer->endTag("double");
        $writer->endTag("value");
    } else {
        $writer->startTag("value");
        $writer->characters($value);
        $writer->endTag("value");
    }
}

sub create_request($$$) {
    my($self, $methodName, $params) = @_;
    my $contents;
    my $writer = XML::Writer->new(OUTPUT => \$contents, ENCODING => "UTF-8");
    $writer->startTag("methodCall");
    $writer->startTag("methodName");
    $writer->characters($methodName);
    $writer->endTag("methodName");
    $writer->startTag("params");
    foreach my $param (@$params) {
        $writer->startTag("param");
        $self->value($writer, $param);
        $writer->endTag("param");
    }
    $writer->endTag("params");
    $writer->endTag("methodCall");
    $writer->end();
    return $contents;
}

sub get_response($$) {
    my($self, $contents) = @_;
    return _get_response($self, { "url" => $self->url() . "/xmlrpc.cgi",
                                  "contentType" => "text/xml",
                                  "contents" => $contents });
}

sub _get_response($$) {
    my($self, $params) = @_;
    my $url = $params->{"url"};
    my $contentType = $params->{"contentType"};
    my $contents = $params->{"contents"};
    if (ref($contents) eq "ARRAY") {
        require URI;
        my $uri = URI->new('http:');
        $uri->query_form($contents);
        $contents = $uri->query();
    }

    my $req = HTTP::Request->new(POST => $url);
    $req->content_type($contentType);
    $req->content($contents);
    if ($self->{'request_only'}) {
        return $req;
    }
    my $ua = $self->user_agent();

    my($logDir,$logId) = $self->logDirectory();

    if ($logDir) {
        $logId = ++$counter;
        require File::Spec;
        my $fileName = File::Spec->catfile($logDir, "$$.$logId.request.log");
        if (open(my $fh, ">", $fileName)) {
	    foreach my $header ($req->header_field_names()) {
		foreach my $value ($req->header($header)) {
		    print $fh "$header: $value\n";
		}
	    }
	    if ($ua->cookie_jar()) {
		print $fh $ua->cookie_jar()->as_string();
	    }
	    print $fh "\n";
            print $fh $contents;
            close($fh);
        }
    }

    my $res = $ua->request($req);
    my $response = $res->is_success() ? $res->content() : undef;
    if ($logDir) {
        my $fileName = File::Spec->catfile($logDir, "$$.$logId.response.log");
        if (open(my $fh, ">", $fileName)) {
	    foreach my $header ($res->header_field_names()) {
		foreach my $value ($res->header($header)) {
		    print $fh "$header: $value\n";
		}
	    }
	    print $fh "\n";
	    if ($res->is_success) {
		print $fh $response;
	    }
            close($fh);
        }
    }
    if (!$res->is_success()) {
        my $msg = $res->status_line();
        my $code = $res->code();
        if ($code == 401) {
           $self->error("Authorization error, perhaps invalid user name and/or password", $code);
        } elsif ($code == 404) {
           $self->error("Bugzilla server not found, perhaps invalid URL.", $code);
        } else {
           $self->error("Unknown error: $msg", $code);
        }
    }

    return $response;
}

sub parse_response($$) {
    my($self, $contents) = @_;
    my $parser = BZ::Client::XMLRPC::Parser->new();
    return $parser->parse($contents);
}

sub request($%) {
    my $self = shift;
    my %args = @_;
    my $methodName = $args{"methodName"};
    $self->error("Missing argument: methodName") unless defined($methodName);
    my $params = $args{"params"};
    $self->error("Missing argument: params") unless defined($params);
    $self->error("Invalid argument: params (Expected array)") unless ref($params) eq "ARRAY";
    my $contents = $self->create_request($methodName, $params);
    $self->log("debug", "BZ::Client::XMLRPC::request: Sending method $methodName to " . $self->url());
    my $response = $self->get_response($contents);
    $self->log("debug", "BZ::Client::XMLRPC::request: Got result for method $methodName");
    return $self->parse_response($response);
}

sub log($$$) {
    my($self, $level, $msg) = @_;
    my $logger = $self->logger();
    if ($logger) {
        &$logger($level, $msg);
    }
}

sub logger($;$) {
    my($self) = shift;
    if (@_) {
        $self->{'logger'} = shift;
    } else {
        return $self->{'logger'};
    }
}

sub logDirectory($;$) {
    my($self) = shift;
    if (@_) {
        $self->{'logDirectory'} = shift;
    } else {
        return $self->{'logDirectory'};
    }
}

package BZ::Client::XMLRPC::int;

sub new($$) {
    my($class, $value) = @_;
    return bless(\$value, (ref($class) || $class));
}

package BZ::Client::XMLRPC::boolean;

sub new($$) {
    my($class, $value) = @_;
    return bless(\$value, (ref($class) || $class));
}

use constant TRUE => BZ::Client::XMLRPC::boolean->new(1);
use constant FALSE => BZ::Client::XMLRPC::boolean->new(0);

package BZ::Client::XMLRPC::double;

sub new($$) {
    my($class, $value) = @_;
    return bless(\$value, (ref($class) || $class));
}

1;

=pod

=head1 NAME

  BZ::Client::XMLRPC - Performs XML-RPC calls on behalf of the client.

=head1 SYNOPSIS

  my $xmlrpc = BZ::Client::XMLRPC->new("url" => $url);
  my $result = $xmlrpc->request("methodName" => $methodName, "params" => $params);

An instance of BZ::Client::XMLRPC is able to perform XML-RPC calls against the
given URL. A request is performed by passing the method name and the method
parameters to the method L</request>. The request result is returned.

=head1 CLASS METHODS

This section lists the possible class methods.

=head2 new

  my $xmlrpc = BZ::Client::XMLRPC->new("url" => $url);

Creates a new instance with the given URL.

=head1 INSTANCE METHODS

This section lists the possible instance methods.

=head2 url

  my $url = $xmlrpc->url();
  $xmlrpc->url($url);

Returns or sets the XML-RPC servers URL.

=head2 request

  my $result = $xmlrpc->request("methodName" => $methodName, "params" => $params);

Calls the XML-RPC servers method C<$methodCall>, passing the parameters given by
C<$params>, an array of parameters. Parameters may be hash refs, array refs, or
atomic values. Array refs and hash refs may recursively contain array or hash
refs as values. An instance of L<BZ::Client::Exception> is thrown in case of
errors.

=head1 SEE ALSO

  L<BZ::Client>, L<BZ::Client::Exception>
