package Mojo::XMLRPC;

use Mojo::Base -strict;

use B ();
use Mojo::ByteStream;
use Mojo::Date;
use Mojo::DOM;
use Mojo::JSON;
use Mojo::Template;
use Scalar::Util ();

use Mojo::XMLRPC::Base64;
use Mojo::XMLRPC::Message::Call;
use Mojo::XMLRPC::Message::Response;

use Exporter 'import';

our @EXPORT_OK = (qw[decode_xmlrpc encode_xmlrpc from_xmlrpc to_xmlrpc]);

our $VERSION = '0.06';
$VERSION = eval $VERSION;

my $message = Mojo::Template->new(
  auto_escape => 1,
  name => 'message',
  namespace => __PACKAGE__,
)->parse(<<'TEMPLATE');
  % my ($tag, $method, @args) = @_;
<?xml version="1.0" encoding="UTF-8"?>
<<%= $tag %>>
% if (defined $method) {
  <methodName><%= $method %></methodName>
% }
% for my $arg (@args) {
  %= $arg
% }
</<%= $tag %>>
TEMPLATE

my $fault = Mojo::Template->new(
  auto_escape => 1,
  name => 'fault',
  namespace => __PACKAGE__,
)->parse(<<'TEMPLATE');
  % my ($code, $string) = @_;
  <fault>
    <value><struct>
      <member>
        <name>faultCode</name>
        <value><int><%= $code // '' %></int></value>
      </member>
      <member>
        <name>faultString</name>
        <value><string><%= $string // '' %></string></value>
      </member>
    </struct></value>
  </fault>
TEMPLATE

my $params = Mojo::Template->new(
  auto_escape => 1,
  name => 'params',
  namespace => __PACKAGE__,
)->parse(<<'TEMPLATE');
  % my (@params) = @_;
  <params>
  % for my $param (@params) {
    <param><value><%= $param %></value></param>
  % }
  </params>
TEMPLATE

sub decode_xmlrpc { from_xmlrpc(Mojo::Util::decode 'UTF-8', $_[0]) }

sub encode_xmlrpc { Mojo::Util::encode 'UTF-8', to_xmlrpc(@_) }

sub from_xmlrpc {
  my ($xml) = shift;

  # parse the XML document
  my $dom = Mojo::DOM->new($xml);
  my $msg;

  # detect the message type
  my $top  = $dom->children->first;
  my $type = $top->tag;
  if ($type eq 'methodCall') {
    $msg = Mojo::XMLRPC::Message::Call->new;
    if (defined(my $method = $top->children('methodName')->first)) {
      $msg->method_name($method->text);
    }

  } elsif ($type eq 'methodResponse') {
    $msg = Mojo::XMLRPC::Message::Response->new;
    if (defined(my $fault = $top->children('fault')->first)) {
      return $msg->fault(_decode_element($fault));
    }

  } else {
    die 'unknown type of message';
  }

  if (defined(my $params = $top->children('params')->first)) {
    $msg->parameters([ map { _decode_element($_) } @{ $params->children('param') } ]);
  }

  return $msg;
}

sub to_xmlrpc {
  my ($type, @args) = @_;

  if (Scalar::Util::blessed($type) && $type->isa('Mojo::XMLRPC::Message')) {
    my $obj = $type;
    if ($obj->isa('Mojo::XMLRPC::Message::Call')) {
      $type = 'call';
      @args = ($obj->method_name, @{ $obj->parameters });
    } elsif ($obj->isa('Mojo::XMLRPC::Message::Response')) {
      $type = $obj->is_fault ? 'fault' : 'response';
      @args = $obj->is_fault ? @{ $obj->fault }{qw/faultCode faultString/} : @{ $obj->parameters };
    } else {
      die 'Message type not understood';
    }
  }

  my $tag    = $type eq 'call' ? 'methodCall' : 'methodResponse';
  my $method = $type eq 'call' ? shift @args  : undef;

  my $xml =
    $type eq 'fault' ? $fault->process(@args) :
    @args ? $params->process(map { _encode_item($_) } @args) :
    undef;

  return $message->process($tag, $method, defined($xml) ? Mojo::ByteStream->new($xml) : ());
}

sub _decode_element {
  my $elem = shift;
  my $tag = $elem->tag;

  if ($tag eq 'param' || $tag eq 'value' || $tag eq 'fault') {
    my $children = $elem->children;

    # elements with no children must be strings
    return $elem->text unless @$children;

    # otherwise they are another element
    return _decode_element($children->first);

  } elsif ($tag eq 'array') {
    my $data = $elem->children('data')->first;
    return [ map { _decode_element($_) } @{ $data->children('value') } ];

  } elsif ($tag eq 'struct') {
    return +{
      map {;
        $_->children('name')->first->text,              # key
        _decode_element($_->children('value')->first)   # value
      }
      @{ $elem->children('member') }  # pairs
    };

  } elsif ($tag eq 'int' || $tag eq 'i4') {
    return $elem->text + 0;

  } elsif ($tag eq 'string' || $tag eq 'name') {
    return $elem->text;

  } elsif ($tag eq 'double') {
    return $elem->text / 1.0;

  } elsif ($tag eq 'boolean') {
    return $elem->text ? Mojo::JSON::true : Mojo::JSON::false;

  } elsif ($tag eq 'nil') {
    return undef;

  } elsif ($tag eq 'dateTime.iso8601') {
    my $date = Mojo::Date->new($elem->text);
    unless ($date->epoch) {
      require Time::Piece;
      my $text = $elem->text;
      PARSE: for my $time_format ('%H:%M:%S', '%H%M%S') {
        for my $calendar_format ('%Y%m%d', '%Y-%m-%d') {
          my $format = $calendar_format . 'T' . $time_format;
          eval {
            $date->epoch(Time::Piece->strptime($text, $format)->epoch);
          };
          last PARSE unless $@;
        }
      }
    }
    return $date;
  } elsif ($tag eq 'base64') {
    return Mojo::XMLRPC::Base64->new(encoded => $elem->text);
  }

  die "unknown tag: $tag";
}

sub _encode_item {
  my $item = shift;
  my $ret;

  if (ref $item) {
    if (Scalar::Util::blessed $item) {
      if ($item->can('TO_XMLRPC')) {
        return _encode_item($item->TO_XMLRPC);

      } elsif ($item->isa('JSON::PP::Boolean')) {
        my $val = $item ? 1 : 0;
        $ret = "<boolean>$val</boolean>";

      } elsif ($item->isa('Mojo::Date')) {
        my $date = $item->to_datetime;
        $ret = "<dateTime.iso8601>$date</dateTime.iso8601>";

      } elsif ($item->isa('Mojo::XMLRPC::Base64')) {
        $ret = "<base64>$item</base64>";

      } elsif ($item->can('TO_JSON')) {
        return _encode_item($item->TO_JSON);

      } else {
        return _encode_item("$item");
      }
    } elsif (ref $item eq 'ARRAY') {
      $ret = join '', map { '<value>' . _encode_item($_) . '</value>' } @$item;
      $ret = "<array><data>$ret</data></array>";

    } elsif (ref $item eq 'HASH') {
      $ret = join '', map {
        my $name = Mojo::Util::xml_escape($_);
        "<member><name>$name</name><value>" . _encode_item($item->{$_}) . '</value></member>';
      } keys %$item;
      $ret = "<struct>$ret</struct>";

    } elsif (ref $item eq 'SCALAR') {
      my $val = $$item ? 1 : 0;
      $ret = "<boolean>$val</boolean>";
    }
  }
  else {
    my $sv = B::svref_2object(\$item);

    $ret =
      !defined $item ? '<nil/>' :
      $sv->FLAGS & B::SVf_NOK ? "<double>$item</double>" :
      $sv->FLAGS & B::SVf_IOK ? "<int>$item</int>" :
      '<string>' . Mojo::Util::xml_escape($item) . '</string>';
  }

  return Mojo::ByteStream->new($ret);
}

1;

=encoding utf8

=head1 NAME

Mojo::XMLRPC - An XMLRPC message parser/encoder using the Mojo stack

=head1 SYNOPSIS

  use Mojo::UserAgent;
  use Mojo::XMLRPC qw[to_xmlrpc from_xmlrpc];

  my $ua = Mojo::UserAgent->new;
  my $url = ...;
  my $tx = $ua->post($url, encode_xmlrpc(call => 'mymethod', 'myarg'));
  my $res = decode_xmlrpc($tx->res->body)

=head1 DESCRIPTION

L<Mojo::XMLRPC> is a pure-perl XML-RPC message parser and encoder.
It uses tools from the L<Mojo> toolkit to do all of the work.

This does not mean that it must only be used in conjunction with a L<Mojolicious> app, far from it.
Feel free to use it in any circumstance that needs XML-RPC messages.

=head1 MAPPING

The mapping between Perl types and XMLRPC types is not perfectly one-to-one, especially given Perl's scalar types.
The following is a description of the procedure used to encode and decode XMLRPC message from/to Perl.

=head2 Perl to XMLRPC

If the item is a blessed reference:

=over

=item *

If the item/object implements a C<TO_XMLRPC> method, it is called and the result is encoded.

=item *

If the item is a L<JSON::PP::Boolean>, as the L<Mojo::JSON> booleans are, it is encoded as a C<boolean>.

=item *

If the item is a L<Mojo::Date> then it is encoded as a C<dateTime.iso8601>.

=item *

If the item is a L<Mojo::XMLRPC::Base64> then it is encode as a C<base64>.
This wrapper class is used to distinguish a string from a base64 and aid in encoding/decoding.

=item

If the item/object implements a C<TO_JSON> method, it is called and the result is encoded.

=item

If none of the above cases are true, the item is stringified and encoded as a C<string>.

=back

If the item is an unblessed reference:

=over

=item *

An array reference is encoded as an C<array>.

=item *

A hash reference is encoded as a C<struct>.

=item *

A scalar reference is encoded as a C<boolean> depending on the truthiness of the referenced value.
This is the standard shortcut seen in JSON modules allowing C<\1> for true and C<\0> for false.

=back

If the item is a non-reference scalar:

=over

=item *

If the item is undefined it is encoded as C<< <nil/> >>.

=item *

If the item has C<NOK> (it has been used as a floating point number) it is encoded as C<double>.

=item *

If the item has C<IOK> (it has been used as an integer (and not a float)) it is encoded as an C<int>.

=item *

All other values are encoded as C<string>.

=back

=head2 XMLRPC to Perl

Most values decode back into Perl in a manner that would survive a round trip.
The exceptions are blessed objects that implement C<TO_XMLRPC> or C<TO_JSON> or are stringified.
The shortcuts for booleans will round-trip to being L<Mojo::JSON> booleans objects.

Values encoded as integers will not be truncated via C<int> however no attempt is made to upgrade them to C<IOK> or C<NOK>.
Values encoded as floating point C<double> will be forcably upgraded to C<NOK> (by dividing by 1.0).
This is so that an integer value encoded as a floating point will round trip, the reverse case isn't as useful and thus isn't handled.

=head1 FUNCTIONS

=head2 decode_xmlrpc

Like L</from_xmlrpc> but first decodes from UTF-8 encoded bytes.

=head2 encode_xmlrpc

Like L</to_xmlrpc> but encodes the result to UTF-8 encoded bytes.

=head2 from_xmlrpc

Takes a character string, interprets it, and returns a L<Mojo::XMLRPC::Message> containing the result.
If the input is UTF-8 encoded bytes, you can use L</decode_xmlrpc> instead.

=head2 to_xmlrpc

Generates an XMLRPC message from data passed to the function.
The input may be a L<Mojo::XMLRPC::Message> or it could be of the following form.

=over

=item *

A message type, one of C<call>, C<response>, C<fault>.

=item *

If the message type is C<call>, then the method name.

=item *

If the message is not a C<fault>, then all remaining arguments are parameters.
If the message is a C<fault>, then the fault code followed by the fault string, all remaining arguments are ignored.

=back

The return value is a character string.
To generate UTF-8 encoded bytes, you can use L</encode_xmlrpc> instead.

=head1 THANKS

This module was inspired by L<XMLRPC::Fast> written by Sébastien Aperghis-Tramoni.

L<Mojo::XMLRPC> was a port of that module initially to use the L<Mojo::DOM> module rather than L<XML::Parser>.
By the time port to the Mojo stack was complete, the module was entirely rewritten.
That said, the algorithm still owes a debt of gratitude to that one.

=head1 SOURCE REPOSITORY

L<http://github.com/jberger/Mojo-XMLRPC>

=head1 AUTHOR

Joel Berger, E<lt>joel.a.berger@gmail.comE<gt>

=head1 CONTRIBUTORS

Andreas Vögele (voegelas)

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2017 by L</AUTHOR> and L</CONTRIBUTORS>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
