File Coverage

blib/lib/RPC/XML/Client.pm

Criterion	Covered	Total	%
statement	78	237	32.9
branch	10	104	9.6
condition	4	46	8.7
subroutine	18	33	54.5
pod	5	5	100.0
total	115	425	27.0

###############################################################################
#
# This file copyright (c) 2001-2014 Randy J. Ray, all rights reserved
#
# Copying and distribution are permitted under the terms of the Artistic
# License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or
# the GNU LGPL (http://www.opensource.org/licenses/lgpl-2.1.php).
#
###############################################################################
#
#   Description:    This class implements an RPC::XML client, using LWP to
#                   manage the underlying communication protocols. It relies
#                   on the RPC::XML transaction core for data management.
#
#   Functions:      new
#                   send_request
#                   simple_request
#                   uri
#                   useragent
#                   request
#
#   Libraries:      LWP::UserAgent
#                   HTTP::Request
#                   URI
#                   RPC::XML
#                   RPC::XML::ParserFactory
#                   Compress::Raw::Zlib is used if available
#
#   Global Consts:  $VERSION
#
###############################################################################

package RPC::XML::Client;

use 5.008008;
use strict;
use warnings;
use vars qw($VERSION $COMPRESSION_AVAILABLE);
use subs qw(new simple_request send_request uri useragent request
            fault_handler error_handler combined_handler timeout);

use Scalar::Util 'blessed';
use File::Temp;
use IO::Handle;
use Module::Load;

use LWP::UserAgent;
use HTTP::Request;
use URI;

use RPC::XML;
use RPC::XML::ParserFactory;

BEGIN
{
    # Check for compression support
    $COMPRESSION_AVAILABLE =
        (eval { load Compress::Zlib; 1; }) ? 'deflate' : q{};
}

$VERSION = '1.42';
$VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)

###############################################################################
#
#   Sub Name:       new
#
#   Description:    Create a LWP::UA instance and add some extra material
#                   specific to our purposes.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $class    in      scalar    Class to bless into
#                   $location in      scalar    URI path for requests to go to
#                   %attrs    in      hash      Extra info
#
#   Globals:        $VERSION
#
#   Returns:        Success:    object reference
#                   Failure:    error string
#
###############################################################################
sub new
{
    my ($class, $location, %attrs) = @_;

    $class = ref($class) || $class;
    if (! $location)
    {
        return "${class}::new: Missing location argument";
    }

    my ($self, $UA, $REQ);

    # Start by getting the LWP::UA object
    $UA = LWP::UserAgent->new(
        (exists $attrs{useragent}) ? @{$attrs{useragent}} : ()
    );
    $UA->agent(sprintf '%s/%s %s', $class, $VERSION, $UA->agent);
    $self->{__useragent} = $UA;
    delete $attrs{useragent};

    # Next get the request object for later use
    $REQ = HTTP::Request->new(POST => $location);
    $self->{__request} = $REQ;
    $REQ->header(Content_Type => 'text/xml');
    $REQ->protocol('HTTP/1.0');

    # Note compression support
    $self->{__compress} = $COMPRESSION_AVAILABLE;
    # It looks wasteful to keep using the hash key, but it makes it easier
    # to change the string in just one place (BEGIN block, above) if I have to.
    # Also (for now) I prefer to manipulate the private keys directly, before
    # blessing $self, rather than using accessors. This is just for performance
    # and I might change my mind later.
    if ($self->{__compress})
    {
        $REQ->header(Accept_Encoding => $self->{__compress});
    }
    $self->{__compress_thresh} = $attrs{compress_thresh} || 4096;
    $self->{__compress_re} = qr/$self->{__compress}/;
    # They can change this value with a method
    $self->{__compress_requests} = 0;
    delete $attrs{compress_thresh};

    # Parameters to control the point at which messages are shunted to temp
    # files due to size, and where to home the temp files. Start with a size
    # threshhold of 1Meg and no specific dir (which will fall-through to the
    # tmpdir() method of File::Spec).
    $self->{__message_file_thresh} = $attrs{message_file_thresh} || 1_048_576;
    $self->{__message_temp_dir}    = $attrs{message_temp_dir}    || q{};
    delete @attrs{qw(message_file_thresh message_temp_dir)};

    # Note and preserve any error or fault handlers. Check the combo-handler
    # first, as it is superceded by anything more specific.
    if (ref $attrs{combined_handler})
    {
        $self->{__error_cb} = $attrs{combined_handler};
        $self->{__fault_cb} = $attrs{combined_handler};
        delete $attrs{combined_handler};
    }
    if (ref $attrs{fault_handler})
    {
        $self->{__fault_cb} = $attrs{fault_handler};
        delete $attrs{fault_handler};
    }
    if (ref $attrs{error_handler})
    {
        $self->{__error_cb} = $attrs{error_handler};
        delete $attrs{error_handler};
    }

    # Get the RPC::XML::Parser instance from the ParserFactory
    $self->{__parser} =
        RPC::XML::ParserFactory->new($attrs{parser} ? @{$attrs{parser}} : ())
              or return "${class}::new: Unable to get RPC::XML::Parser object";
    delete $attrs{parser};

    # Now preserve any remaining attributes passed in
    for (keys %attrs)
    {
        $self->{$_} = $attrs{$_};
    }

    return bless $self, $class;
}

###############################################################################
#
#   Sub Name:       simple_request
#
#   Description:    Simplify the request process by both allowing for direct
#                   data on the incoming side, and for returning a native
#                   value rather than an object reference.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Class instance
#                   @args     in      list      Various args -- see comments
#
#   Globals:        $RPC::XML::ERROR
#
#   Returns:        Success:    value
#                   Failure:    undef, error in $RPC::XML::ERROR
#
###############################################################################
sub simple_request
{
    my ($self, @args) = @_;

    my $return;

    $RPC::XML::ERROR = q{};

    $return = $self->send_request(@args);
    if (! ref $return)
    {
        $RPC::XML::ERROR = ref($self) . "::simple_request: $return";
        return;
    }

    return $return->value;
}

###############################################################################
#
#   Sub Name:       send_request
#
#   Description:    Take a RPC::XML::request object, dispatch a request, and
#                   parse the response. The return value should be a
#                   RPC::XML::response object, or an error string.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Class instance
#                   $req      in      ref       RPC::XML::request object or
#                                                 remote method name
#                   @args     in      list      If $req is a method name, these
#                                                 are potential arguments for
#                                                 the remote call
#
#   Returns:        Success:    RPC::XML::response object instance
#                   Failure:    error string
#
###############################################################################
sub send_request ## no critic (ProhibitExcessComplexity)
{
    my ($self, $req, @args) = @_;

    my ($me, $message, $response, $reqclone, $content, $can_compress, $value,
        $do_compress, $req_fh, $tmpdir, $com_engine);

    $me = ref($self) . '::send_request';

    if (! $req)
    {
        return "$me: No request object or remote method name given";
    }
    elsif (! (blessed $req and $req->isa('RPC::XML::request')))
    {
        # Assume that $req is the name of the routine to be called
        if (! ($req = RPC::XML::request->new($req, @args)))
        {
            return "$me: Error creating RPC::XML::request object: " .
                $RPC::XML::ERROR;
        }
    }

    # Start by setting up the request-clone for using in this instance
    $reqclone = $self->request->clone;
    if (! $reqclone->header('Host')) {
        $reqclone->header(Host => URI->new($reqclone->uri)->host_port);
    }
    $can_compress = $self->compress; # Avoid making 4+ calls to the method
    if ($self->compress_requests and $can_compress and
        $req->length >= $self->compress_thresh)
    {
        # If this is a candidate for compression, set a flag and note it
        # in the Content-encoding header.
        $do_compress = 1;
        $reqclone->content_encoding($can_compress);
    }

    # Next step, determine our content's disposition. If it is above the
    # threshhold for a requested file cut-off, send it to a temp file and use
    # a closure on the request object to manage content.
    if ($self->message_file_thresh and
        $self->message_file_thresh <= $req->length)
    {
        require File::Spec;
        # Start by creating a temp-file
        $tmpdir = $self->message_temp_dir || File::Spec->tmpdir;
        # File::Temp->new() croaks on error, rather than just returning undef
        $req_fh = eval { File::Temp->new(UNLINK => 1, DIR => $tmpdir) };
        if (! $req_fh)
        {
            return "$me: Error opening tmpfile: $@";
        }
        binmode $req_fh;
        # Make it auto-flush
        $req_fh->autoflush();

        # Now that we have it, spool the request to it. This is a little
        # hairy, since we still have to allow for compression. And though the
        # request could theoretically be HUGE, in order to compress we have to
        # write it to a second temp-file first, so that we can compress it
        # into the primary handle.
        if ($do_compress && ($req->length >= $self->compress_thresh))
        {
            my $fh_compress = eval {
                File::Temp->new(UNLINK => 1, DIR => $tmpdir);
            };
            if (! $fh_compress)
            {
                return "$me: Error opening compression tmpfile: $@";
            }
            # Make it auto-flush
            $fh_compress->autoflush();

            # Write the request to the second FH
            $req->serialize($fh_compress);
            seek $fh_compress, 0, 0;

            # Spin up the compression engine
            $com_engine = Compress::Zlib::deflateInit();
            if (! $com_engine)
            {
                return "$me: Unable to initialize the Compress::Zlib engine";
            }

            # Spool from the second FH through the compression engine, into
            # the intended FH.
            my $buf = q{};
            my $out;
            while (read $fh_compress, $buf, 4096)
            {
                $out = $com_engine->deflate(\$buf);
                if (! defined $out)
                {
                    return "$me: Compression failure in deflate()";
                }
                print {$req_fh} $out;
            }
            # Make sure we have all that's left
            $out = $com_engine->flush;
            if (! defined $out)
            {
                return "$me: Compression flush failure in deflate()";
            }
            print {$req_fh} $out;

            # Close the secondary FH. Rewinding the primary is done later.
            if (! close $fh_compress)
            {
                return "$me: Error closing spool-file: $!";
            }
        }
        else
        {
            $req->serialize($req_fh);
        }
        seek $req_fh, 0, 0;

        $reqclone->content_length(-s $req_fh);
        $reqclone->content(sub {
                               my $b = q{};
                               if (! defined read $req_fh, $b, 4096)
                               {
                                   return;
                               }

                               return $b;
                           });
    }
    else
    {
        # Treat the content strictly in-memory
        utf8::encode($content = $req->as_string);
        if ($do_compress)
        {
            $content = Compress::Zlib::compress($content);
        }
        $reqclone->content($content);
        # Because $content has been force-downgraded, length() should work
        $reqclone->content_length(length $content);
    }

    # Content used to be handled as an in-memory string. Now, to avoid eating
    # up huge chunks due to potentially-massive messages (thanks Tellme), we
    # parse incrementally with the XML::Parser::ExpatNB class. What's more,
    # to use the callback-form of request(), we can't get just the headers
    # first. We have to check things like compression and such on the fly.
    my $compression;
    my $parser = $self->parser->parse(); # Gets the ExpatNB object
    my $cb = sub {
        my ($data_in, $resp) = @_;

        if (! defined $compression)
        {
            $compression =
                (($resp->content_encoding || q{}) =~
                 $self->compress_re) ? 1 : 0;
            if ($compression and (! $can_compress))
            {
                die "$me: Compressed content encoding not supported\n";
            }
            if ($compression)
            {
                if (! ($com_engine = Compress::Zlib::inflateInit()))
                {
                    die "$me: Unable to initialize de-compression engine\n";
                }
            }
        }

        if ($compression)
        {
            my $error;
            if (! (($data_in, $error) = $com_engine->inflate($data_in)))
            {
                die "$me: Error in inflate() expanding data: $error\n";
            }
        }

        $parser->parse_more($data_in);
        1;
    };

    $response = $self->useragent->request($reqclone, $cb);
    if ($message = $response->headers->header('X-Died'))
    {
        # One of the die's was triggered
        return ('CODE' eq ref $self->error_handler) ?
            $self->error_handler->($message) : $message;
    }
    if (! $response->is_success)
    {
        $message =  "$me: HTTP server error: " . $response->message;
        return ('CODE' eq ref $self->error_handler) ?
            $self->error_handler->($message) : $message;
    }

    # Whee. No errors from the callback or the server. Finalize the parsing
    # process.
    if (! eval { $value = $parser->parse_done(); 1; })
    {
        if ($@)
        {
            # One of the die's was triggered
            return ('CODE' eq ref $self->error_handler) ?
                $self->error_handler->($@) : $@;
        }
    }

    # Check if there is a callback to be invoked in the case of
    # errors or faults
    if (! ref $value)
    {
        $message =  "$me: parse-level error: $value";
        return ('CODE' eq ref $self->error_handler) ?
            $self->error_handler->($message) : $message;
    }
    elsif ($value->is_fault)
    {
        return ('CODE' eq ref $self->fault_handler) ?
            $self->fault_handler->($value->value) : $value->value;
    }

    return $value->value;
}

###############################################################################
#
#   Sub Name:       timeout
#
#   Description:    Get or set the timeout() setting on the underlying
#                   LWP::UserAgent object.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $time     in      scalar    New timeout value, if passed
#
#   Returns:        Return value from LWP::UserAgent->timeout()
#
###############################################################################
sub timeout ## no critic (RequireArgUnpacking)
{
    my $self = shift;

    return $self->useragent->timeout(@_);
}

###############################################################################
#
#   Sub Name:       uri
#
#   Description:    Get or set the URI portion of the request
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $uri      in      scalar    New URI, if passed
#
#   Returns:        Current URI, undef if trying to set an invalid URI
#
###############################################################################
sub uri ## no critic (RequireArgUnpacking)
{
    my $self = shift;

    return $self->request->uri(@_);
}

###############################################################################
#
#   Sub Name:       credentials
#
#   Description:    Set basic-auth credentials on the underlying user-agent
#                   object
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $realm    in      scalar    Realm to authenticate for
#                   $user     in      scalar    User name to authenticate
#                   $pass     in      scalar    Password for $user
#
#   Returns:        $self
#
###############################################################################
sub credentials
{
    my ($self, $realm, $user, $pass) = @_;

    my $uri = URI->new($self->uri);
    $self->useragent->credentials($uri->host_port, $realm, $user, $pass);

    return $self;
}

# Immutable accessor methods
BEGIN
{
    no strict 'refs'; ## no critic (ProhibitNoStrict)

    for my $method (qw(useragent request compress_re compress parser))
    {
        *{$method} = sub { shift->{"__$method"} }
    }
}

# Fetch/set the compression threshhold
sub compress_thresh
{
    my $self = shift;
    my $value = shift || 0;

    my $old = $self->{__compress_thresh};
    if ($value)
    {
        $self->{__compress_thresh} = $value;
    }

    return $old;
}

# This doesn't actually *get* the original value, it only sets the value
sub compress_requests
{
    my ($self, $value) = @_;

    if (! $value)
    {
        return $self->{__compress_requests};
    }

    return $self->{__compress_requests} = $value ? 1 : 0;
}

# These are get/set accessors for the fault-handler, error-handler and the
# combined fault/error handler.
sub fault_handler
{
    my ($self, $newval) = @_;

    my $val = $self->{__fault_cb};
    if ($newval and ref $newval)
    {
        $self->{__fault_cb} = $newval;
    }
    # Special: an explicit undef is used to clear the callback
    if (@_ == 2 and (! defined $newval))
    {
        $self->{__fault_cb} = undef;
    }

    return $val;
}

sub error_handler
{
    my ($self, $newval) = @_;

    my $val = $self->{__error_cb};
    if ($newval and ref $newval)
    {
        $self->{__error_cb} = $newval;
    }
    # Special: an explicit undef is used to clear the callback
    if (@_ == 2 and (! defined $newval))
    {
        $self->{__error_cb} = undef;
    }

    return $val;
}

sub combined_handler
{
    my ($self, $newval) = @_;

    return ($self->fault_handler($newval), $self->error_handler($newval));
}

# Control whether, and at what point, messages are considered too large to
# handle in-memory.
sub message_file_thresh
{
    my ($self, $thresh) = @_;

    if (! $thresh)
    {
        return $self->{__message_file_thresh};
    }

    return $self->{__message_file_thresh} = $thresh;
}

sub message_temp_dir
{
    my ($self, $dir) = @_;

    if (! $dir)
    {
        return $self->{__message_temp_dir};
    }

    return $self->{__message_temp_dir} = $dir;
}

1;

__END__