File Coverage

blib/lib/Mojo/XMLRPC.pm

Criterion	Covered	Total	%
statement	122	129	94.5
branch	77	88	87.5
condition	13	15	86.6
subroutine	18	18	100.0
pod	4	4	100.0
total	234	254	92.1

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) = @_;

<<%= $tag %>>
% if (defined $method) {
  <%= $method %>
% }
% for my $arg (@args) {
  %= $arg
% }
>
TEMPLATE

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



        faultCode
        <%= $code // '' %>


        faultString
        <%= $string // '' %>



TEMPLATE

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

  % for my $param (@params) {
    <%= $param %>
  % }

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 = "$val";

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

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

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

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

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

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

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

  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 is a pure-perl XML-RPC message parser and encoder.
It uses tools from the L toolkit to do all of the work.

This does not mean that it must only be used in conjunction with a L 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 method, it is called and the result is encoded.

=item *

If the item is a L, as the L booleans are, it is encoded as a C.

=item *

If the item is a L then it is encoded as a C.

=item *

If the item is a L then it is encode as a C.
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 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.

=back

If the item is an unblessed reference:

=over

=item *

An array reference is encoded as an C.

=item *

A hash reference is encoded as a C.

=item *

A scalar reference is encoded as a C 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<<  >>.

=item *

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

=item *

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

=item *

All other values are encoded as C.

=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 or C or are stringified.
The shortcuts for booleans will round-trip to being L booleans objects.

Values encoded as integers will not be truncated via C however no attempt is made to upgrade them to C or C.
Values encoded as floating point C will be forcably upgraded to C (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 but first decodes from UTF-8 encoded bytes.

=head2 encode_xmlrpc

Like L but encodes the result to UTF-8 encoded bytes.

=head2 from_xmlrpc

Takes a character string, interprets it, and returns a L containing the result.
If the input is UTF-8 encoded bytes, you can use L instead.

=head2 to_xmlrpc

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

=over

=item *

A message type, one of C, C, C.

=item *

If the message type is C, then the method name.

=item *

If the message is not a C, then all remaining arguments are parameters.
If the message is a C, 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 instead.

=head1 THANKS

This module was inspired by L written by Sébastien Aperghis-Tramoni.

L was a port of that module initially to use the L module rather than L.
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

=head1 AUTHOR

Joel Berger, [e-mail]

=head1 CONTRIBUTORS

Andreas Vögele (voegelas)

=head1 COPYRIGHT AND LICENSE

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