File Coverage

blib/lib/XMLRPC/Fast.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package XMLRPC::Fast;

use strict;
use warnings;

use B               qw< svref_2object SVf_IOK SVf_NOK >;
use Encode;
use Exporter        qw< import >;
use MIME::Base64;
use XML::Parser;


our $VERSION = "0.10";

our @EXPORT = qw<
    decode_xmlrpc encode_xmlrpc
    encode_xmlrpc_request encode_xmlrpc_response encode_xmlrpc_fault
>;


my $utf8 = find_encoding("UTF-8");



#
# encode_xmlrpc_request()
# ---------------------
sub encode_xmlrpc_request {
    encode_xmlrpc(method => @_)
}


#
# encode_xmlrpc_response()
# ----------------------
sub encode_xmlrpc_response {
    encode_xmlrpc(response => "", @_)
}


#
# encode_xmlrpc_fault()
# -------------------
sub encode_xmlrpc_fault {
    encode_xmlrpc(fault => "", $_[0], $_[1])
}


#
# encode_xmlrpc()
# -------------
sub encode_xmlrpc {
    my ($type, $method, @args) = @_;

    my $tag = $type eq "method" ? "methodCall" : "methodResponse";

    my $xml = q{};
    $xml .= "<$tag>";
    $xml .= "$method" if $type eq "method";

    if ($type eq "fault") {
        $args[0] //= "";
        $args[1] //= "";

        $xml .= "faultCode"
              . "$args[0]"
              . "faultString"
              . "$args[1]"
              . ""
    }
    else {
        if (@args) {
            $xml .= "";
            $xml .= "".encode_xmlrpc_thing($_).""
                for @args;
            $xml .= "";
        }
    }

    $xml .= "";
}


#
# encode_xmlrpc_thing()
# -------------------
sub encode_xmlrpc_thing {
    if (ref $_[0]) {
        # handle structures and objects
        my $struct = $_[0];

        if (ref $struct eq "ARRAY") {
            return join "",
                "",
                (map encode_xmlrpc_thing($_), @$struct),
                ""
        }
        elsif (ref $struct eq "HASH") {
            return join "",
                "",
                (map "$_"
                    . encode_xmlrpc_thing($struct->{$_})
                    . "",
                    keys %$struct),
                ""
        }
        elsif (ref $struct eq "DateTime") {
            my $date = $struct->strftime("%Y-%m-%dT%H:%M:%S");
            return "$date"
        }
        elsif (ref $struct eq "DateTime::Tiny") {
            my $date = $struct->as_string;
            return "$date"
        }
    }
    else {
        # handle scalar values
        return "" if not defined $_[0];

        my $copy  = $_[0];
        my $sv    = svref_2object(\$_[0]);

        return "$copy" if $sv->FLAGS & SVf_NOK;
        return "$copy"       if $sv->FLAGS & SVf_IOK;

        if (Encode::is_utf8($_[0])) {
            $copy = $utf8->encode($_[0]);
        }

        if ($copy ne $_[0] or $copy =~ /[^\x09\x0a\x0d\x20-\x7f]/) {
            return "" . encode_base64($copy, "") . ""
        }
        else {
            $copy =~ s/&/&/g;
            $copy =~ s/
            $copy =~ s/>/>/g;
            return "$copy"
        }
    }
}


#
# decode_xmlrpc()
# -------------
sub decode_xmlrpc {
    my ($xml) = shift;

    # parse the XML document
    my $parser = XML::Parser->new(Style => "Tree");
    my $tree = $parser->parse($xml);
    my $root = $tree->[1];
    my %struct;

    # detect the message type
    if ($tree->[0] eq "methodCall") {
        $struct{type} = "request";
    }
    elsif ($tree->[0] eq "methodResponse") {
        $struct{type} = "response";
    }
    else {
        die "unknown type of message";
    }

    # handle first-level elements + detect if fault message
    while (defined (my $e = shift @$root)) {
        next if ref $e eq "HASH";           # skip attributes
        shift @$root and next if $e eq "0"; # skip text outside elements

        if ($e eq "params") {
            $struct{params} = [ decode_node(shift @$root) ];
        }
        elsif ($e eq "methodName") {
            $struct{methodName} = (shift @$root)->[2];
        }
        elsif ($e eq "fault") {
            %struct = (
                type    => "fault",
                fault   => decode_node(shift @$root),
            );
        }
    }

    return \%struct;
}


#
# decode_node()
# -----------
sub decode_node {
    my ($node) = shift;
    my @result;

    while (defined (my $e = shift @$node)) {
        next if ref $e eq "HASH";           # skip attributes
        shift @$node and next if $e eq "0"; # skip text outside elements

        if ($e eq "value") {
            # small dance to correctly handle empty values, which must
            # generate an undef in order to keep things balanced
            my $v = shift @$node;
            push @result, @$v > 1 ? decode_node($v) : undef;
        }
        elsif ($e eq "data" or $e eq "member" or $e eq "param") {
            push @result, decode_node(shift @$node);
        }
        elsif ($e eq "array") {
            push @result, [ decode_node(shift @$node) ];
        }
        elsif ($e eq "struct") {
            push @result, { decode_node(shift @$node) };
        }
        elsif ($e eq "int" or $e eq "i4" or $e eq "boolean") {
            push @result, int((shift @$node)->[2]);
        }
        elsif ($e eq "double") {
            push @result, (shift @$node)->[2] / 1.0;
        }
        elsif ($e eq "string" or $e eq "name" or $e eq "dateTime.iso8601") {
            push @result, (shift @$node)->[2];
        }
        elsif ($e eq "base64") {
            push @result, decode_base64((shift @$node)->[2]);
        }
        elsif ($e eq "nil") {
            push @result, undef;
        }
    }

    return @result
}



__END__