File Coverage

blib/lib/RPC/XML/Server.pm

Criterion	Covered	Total	%
statement	216	555	38.9
branch	43	228	18.8
condition	24	125	19.2
subroutine	35	52	67.3
pod	21	26	80.7
total	339	986	34.3

###############################################################################
#
# 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 server, using the core
#                   XML::RPC transaction code. The server may be created with
#                   or without an HTTP::Daemon object instance to answer the
#                   requests.
#
#   Functions:      new
#                   version
#                   url
#                   product_tokens
#                   started
#                   path
#                   host
#                   port
#                   requests
#                   response
#                   compress
#                   compress_thresh
#                   compress_re
#                   message_file_thresh
#                   message_temp_dir
#                   xpl_path
#                   add_method
#                   method_from_file
#                   get_method
#                   server_loop
#                   post_configure_hook
#                   pre_loop_hook
#                   process_request
#                   dispatch
#                   call
#                   add_default_methods
#                   add_methods_in_dir
#                   delete_method
#                   list_methods
#                   share_methods
#                   copy_methods
#                   timeout
#                   server_fault
#
#   Libraries:      HTTP::Daemon (conditionally)
#                   HTTP::Response
#                   HTTP::Status
#                   URI
#                   Scalar::Util
#                   RPC::XML
#                   RPC::XML::ParserFactory
#                   RPC::XML::Procedure
#                   Compress::Raw::Zlib is used if available
#
#   Global Consts:  $VERSION
#                   $INSTALL_DIR
#                   %FAULT_TABLE
#
###############################################################################

package RPC::XML::Server;

use 5.008008;
use strict;
use warnings;
use vars qw($VERSION $INSTALL_DIR %FAULT_TABLE  @XPL_PATH %CLASS_MAP
            $IO_SOCKET_SSL_HACK_NEEDED $COMPRESSION_AVAILABLE);

use Carp qw(carp croak);
use File::Spec;
use File::Temp;
use IO::Handle;
use Module::Load;
use Scalar::Util 'blessed';

use HTTP::Status;
use HTTP::Response;
use URI;

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

BEGIN
{
    $INSTALL_DIR =
        File::Spec->catpath((File::Spec->splitpath(__FILE__))[0, 1], q{});
    @XPL_PATH = ($INSTALL_DIR, File::Spec->curdir);

    # For now, I have an ugly hack in place to make the functionality that
    # runs under HTTP::Daemon/Net::Server work better with SSL. This flag
    # starts out true, then gets set to false the first time the hack is
    # applied, so that it doesn't get repeated over and over...
    $IO_SOCKET_SSL_HACK_NEEDED = 1;

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

    # Set up the initial table of fault-types and their codes/messages
    %FAULT_TABLE = (
        badxml       => [ 100 => 'XML parse error: %s' ],
        badmethod    => [ 200 => 'Method lookup error: %s' ],
        badsignature => [ 201 => 'Method signature error: %s' ],
        execerror    => [ 300 => 'Code execution error: %s' ],
    );

    # This is used by add_method to map "types" to instantiation classes
    %CLASS_MAP = (
        method    => 'RPC::XML::Method',
        procedure => 'RPC::XML::Procedure',
        function  => 'RPC::XML::Function',
    );
}

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

###############################################################################
#
#   Sub Name:       new
#
#   Description:    Create a new RPC::XML::Server object. This entails getting
#                   a HTTP::Daemon object, saving several internal values, and
#                   other operations.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $class    in      scalar    Ref or string for the class
#                   %args     in      hash      Additional arguments
#
#   Returns:        Success:    object reference
#                   Failure:    error string
#
###############################################################################
sub new ## no critic (ProhibitExcessComplexity)
{
    my ($class, %args) = @_;

    my (
        $self, $http, $resp, $host, $port, $queue, $URI, $srv_version,
        $srv_name
    );

    # Don't accept a blessed value for $class
    if (ref $class)
    {
        return __PACKAGE__ . '::new: Must be called as a static method';
    }

    $self = bless {}, $class;

    $srv_version = delete $args{server_version} || $self->version;
    $srv_name    = delete $args{server_name}    || $class;
    $self->{__server_token} = "$srv_name/$srv_version";

    if (delete $args{no_http})
    {
        $self->{__host} = delete $args{host} || q{};
        $self->{__port} = delete $args{port} || q{};
    }
    else
    {
        require HTTP::Daemon;

        $host  = delete $args{host}  || q{};
        $port  = delete $args{port}  || q{};
        $queue = delete $args{queue} || 5;
        $http  = HTTP::Daemon->new(
            Reuse => 1,
            ($host  ? (LocalHost => $host)  : ()),
            ($port  ? (LocalPort => $port)  : ()),
            ($queue ? (Listen    => $queue) : ())
        );
        if (! $http)
        {
            return "${class}::new: Unable to create HTTP::Daemon object: $@";
        }
        $URI              = URI->new($http->url);
        $self->{__host}   = $URI->host;
        $self->{__port}   = $URI->port;
        $self->{__daemon} = $http;
    }

    # Create and store the cached response object for later cloning and use
    $resp = HTTP::Response->new();
    $resp->header(
        # This is essentially the same string returned by the
        # default "identity" method that may be loaded from a
        # XPL file. But it hasn't been loaded yet, and may not
        # be, hence we set it here (possibly from option values)
        RPC_Server   => $self->{__server_token},
        RPC_Encoding => 'XML-RPC',
        # Set any other headers as well
        Accept => 'text/xml'
    );
    $resp->content_type('text/xml');
    $resp->code(RC_OK);
    $resp->message('OK');
    $self->{__response} = $resp;

    # Basic (scalar) properties
    $self->{__path}         = delete $args{path} || q{};
    $self->{__started}      = 0;
    $self->{__method_table} = {};
    $self->{__requests}     = 0;
    $self->{__auto_methods} = delete $args{auto_methods} || 0;
    $self->{__auto_updates} = delete $args{auto_updates} || 0;
    $self->{__debug}        = delete $args{debug} || 0;
    $self->{__xpl_path}     = delete $args{xpl_path} || [];
    $self->{__timeout}      = delete $args{timeout} || 10;
    $self->{__parser}       = RPC::XML::ParserFactory->new(
        $args{parser} ? @{delete $args{parser}} : ()
    );

    # Add the basic paths (content of @XPL_PATH) to our local XPL path
    push @{$self->{__xpl_path}}, @XPL_PATH;

    # Set up the default methods unless requested not to
    if (! delete $args{no_default})
    {
        $self->add_default_methods;
    }

    # Compression support
    if (delete $args{no_compress})
    {
        $self->{__compress} = q{};
    }
    else
    {
        $self->{__compress} = $COMPRESSION_AVAILABLE;
        # Add some more headers to the default response object for compression.
        # It looks wasteful to keep using the hash key, but it makes it easier
        # to change the string in just one place (above) if I have to.
        if ($self->{__compress})
        {
            $resp->header(Accept_Encoding => $self->{__compress});
        }
        $self->{__compress_thresh} = delete $args{compress_thresh} || 4096;
        # Yes, I know this is redundant. It's for future expansion/flexibility.
        $self->{__compress_re} =
            $self->{__compress} ? qr/$self->{__compress}/ : qr/deflate/;
    }

    # 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} = delete $args{message_file_thresh} ||
        1_048_576;
    $self->{__message_temp_dir} = delete $args{message_temp_dir} || q{};

    # Set up the table of response codes/messages that will be used when the
    # server is sending a controlled error message to a client (as opposed to
    # something HTTP-level that is less within our control).
    $self->{__fault_table} = {};
    for my $fault (keys %FAULT_TABLE)
    {
        $self->{__fault_table}->{$fault} = [ @{$FAULT_TABLE{$fault}} ];
    }
    if ($args{fault_code_base})
    {
        my $base = delete $args{fault_code_base};
        # Apply the numerical offset to all (current) error codes
        for my $key (keys %{$self->{__fault_table}})
        {
            $self->{__fault_table}->{$key}->[0] += $base;
        }
    }
    if ($args{fault_table})
    {
        my $local_table = delete $args{fault_table};
        # Merge any data from this table into the object's fault-table
        for my $key (keys %{$local_table})
        {
            $self->{__fault_table}->{$key} = (ref $local_table->{$key}) ?
                [ @{$local_table->{$key}} ] : $local_table->{$key};
        }
    }

    # Copy the remaining args over untouched
    for (keys %args)
    {
        $self->{$_} = $args{$_};
    }

    return $self;
}

# Most of these tiny subs are accessors to the internal hash keys. They not
# only control access to the internals, they ease sub-classing.

sub version { return $VERSION }

sub INSTALL_DIR { return $INSTALL_DIR }

sub url
{
    my $self = shift;

    my $host;

    if ($self->{__daemon})
    {
        return $self->{__daemon}->url;
    }
    if (! ($host = $self->host))
    {
        return;
    }

    my $path = $self->path;
    my $port = $self->port;
    if ($port == 443)
    {
        return "https://$host$path";
    }
    elsif ($port == 80)
    {
        return "http://$host$path";
    }
    else
    {
        return "http://$host:$port$path";
    }
}

sub product_tokens
{
    my $self = shift;

    my $class = ref $self;
    $class ||= $self;
    return sprintf '%s/%s', $class, $self->version;
}

# This fetches/sets the internal "started" timestamp. Unlike the other
# plain-but-mutable attributes, this isn't set to the passed-value but
# rather a non-null argument sets it from the current time.
sub started
{
    my ($self, $set_started) = @_;

    my $old = $self->{__started} || 0;
    if ($set_started)
    {
        $self->{__started} = time;
    }

    return $old;
}

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

    # These are mutable member values for which the logic only differs in
    # the name of the field to modify:
    for my $method (qw(compress_thresh message_file_thresh message_temp_dir))
    {
        *{$method} = sub {
            my ($self, $value) = @_;

            my $old = $self->{"__$method"};
            if (defined $value)
            {
                $self->{"__$method"} = $value;
            }

            $old;
        }
    }

    # These are immutable member values, so this simple block applies to all
    for my $method (qw(path host port requests response compress compress_re
                       parser))
    {
        *{$method} = sub { shift->{"__$method"} }
    }
}

# Get/set the search path for XPL files
sub xpl_path
{
    my ($self, $path) = @_;
    my $ret  = $self->{__xpl_path};

    if ($path && ref $path eq 'ARRAY')
    {
        $self->{__xpl_path} = $path;
    }

    return $ret;
}

###############################################################################
#
#   Sub Name:       add_method
#
#   Description:    Add a funtion-to-method mapping to the server object.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object to add to
#                   $meth     in      scalar    Hash ref of data or file name
#
#   Globals:        %CLASS_MAP
#
#   Returns:        Success:    $self
#                   Failure:    error string
#
###############################################################################
sub add_method
{
    my ($self, $meth) = @_;

    my $me = ref($self) . '::add_method';

    if (! ref $meth)
    {
        my $val = $self->method_from_file($meth);
        if (! ref $val)
        {
            return "$me: Error loading from file $meth: $val";
        }
        else
        {
            $meth = $val;
        }
    }
    elsif (ref $meth eq 'HASH')
    {
        # Make a copy of the contents of $meth, so we don't make permanent
        # changes:
        my %meth_copy = map { $_ => $meth->{$_} } (keys %{$meth});

        # If the type of this method is not set, default to "method". The
        # add_procedure and add_function calls should set this as needed.
        my $type = delete $meth_copy{type} || 'method';

        if (! (my $class = $CLASS_MAP{lc $type}))
        {
            return "$me: Unknown type: $type";
        }
        else
        {
            $meth = $class->new(\%meth_copy);
        }
    }
    elsif (! (blessed $meth and $meth->isa('RPC::XML::Procedure')))
    {
        return "$me: Method argument must be a file name, a hash " .
            'reference or an object derived from RPC::XML::Procedure';
    }

    $self->{__method_table}->{$meth->name} = $meth;

    return $self;
}

###############################################################################
#
#   Sub Name:       add_procedure
#
#   Description:    This filters through to add_method, but if the passed-in
#                   value is a hash reference forces the "type" to be
#                   "procedure".
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object reference
#                   $meth     in      scalar    Procedure to add
#
#   Returns:        threads through to add_method
#
###############################################################################
sub add_procedure
{
    my ($self, $meth) = @_;

    # Anything else but a hash-reference goes through unaltered
    if (ref($meth) eq 'HASH')
    {
        $meth->{type} = 'procedure';
    }

    return $self->add_method($meth);
}

###############################################################################
#
#   Sub Name:       add_function
#
#   Description:    This filters through to add_method, but if the passed-in
#                   value is a hash reference forces the "type" to be
#                   "function".
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object reference
#                   $meth     in      scalar    Procedure to add
#
#   Returns:        threads through to add_method
#
###############################################################################
sub add_function
{
    my ($self, $meth) = @_;

    # Anything else but a hash-reference goes through unaltered
    if (ref($meth) eq 'HASH')
    {
        $meth->{type} = 'function';
    }

    return $self->add_method($meth);
}

###############################################################################
#
#   Sub Name:       method_from_file
#
#   Description:    Create a RPC::XML::Procedure (or ::Method) object from the
#                   passed-in file name, using the object's search path if the
#                   name is not already absolute.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $file     in      scalar    Name of file to load
#
#   Returns:        Success:    Method-object reference
#                   Failure:    error message
#
###############################################################################
sub method_from_file
{
    my ($self, $file) = @_;

    if (! File::Spec->file_name_is_absolute($file))
    {
        my $path;
        for my $dir (@{$self->xpl_path})
        {
            $path = File::Spec->catfile($dir, $file);
            if (-f $path)
            {
                $file = File::Spec->canonpath($path);
                last;
            }
        }
    }
    # Just in case it still didn't appear in the path, we really want an
    # absolute path:
    if (! File::Spec->file_name_is_absolute($file))
    {
        $file = File::Spec->rel2abs($file);
    }

    # When reading a XPL file, RPC::XML::Procedure->new() acts sort of like a
    # factory constructor, returning the type of object the XPL file specifies
    # even when that isn't RPC::XML::Procedure.
    return RPC::XML::Procedure->new($file);
}

###############################################################################
#
#   Sub Name:       get_method
#
#   Description:    Get the current binding for the remote-side method $name.
#                   Returns undef if the method is not defined for the server
#                   instance.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Class instance
#                   $name     in      scalar    Name of the method being looked
#                                                 up
#
#   Returns:        Success:    Method-class reference
#                   Failure:    error string
#
###############################################################################
sub get_method
{
    my ($self, $name) = @_;

    my $meth = $self->{__method_table}->{$name};
    if (! defined $meth)
    {
        if ($self->{__auto_methods})
        {
            # Try to load this dynamically on the fly, from any of the dirs
            # that are in this object's @xpl_path
            (my $loadname = $name) =~ s/^system[.]//;
            $self->add_method("$loadname.xpl");
        }
        # If method is still not in the table, we were unable to load it
        if (! ($meth = $self->{__method_table}->{$name}))
        {
            return "Unknown method: $name";
        }
    }
    # Check the mod-time of the file the method came from, if the test is on
    if ($self->{__auto_updates} &&
        $meth->{file} &&
        ($meth->{mtime} < (stat $meth->{file})[9]))
    {
        my $ret = $meth->reload;
        if (! ref $ret)
        {
            return "Reload of method $name failed: $ret";
        }
    }

    return $meth;
}

# For name-symmetry:
*get_procedure = *get_function = \&get_method;

###############################################################################
#
#   Sub Name:       server_loop
#
#   Description:    Enter a server-loop situation, using the accept() loop of
#                   HTTP::Daemon if $self has such an object, or falling back
#                   Net::Server otherwise.
#
#                   The critic disabling is because we may manipulate @_
#                   when using Net::Server.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   %args     in      hash      Additional parameters to set up
#                                                 before calling the superclass
#                                                 Run method
#
#   Returns:        string if error, otherwise void
#
###############################################################################
sub server_loop ## no critic (RequireArgUnpacking,ProhibitExcessComplexity)
{
    my $self = shift;

    if ($self->{__daemon})
    {
        my ($conn, $req, $resp, $reqxml, $respxml, $exit_now, $timeout,
            $eval_return);

        my %args = @_;

        # Localize and set the signal handler as an exit route
        my @exit_signals;

        if (exists $args{signal} and $args{signal} ne 'NONE')
        {
            @exit_signals =
                (ref $args{signal}) ? @{$args{signal}} : $args{signal};
        }
        else
        {
            push @exit_signals, 'INT';
        }

        local @SIG{@exit_signals} = (sub { $exit_now++ }) x @exit_signals;

        $self->started('set');
        $exit_now = 0;
        $timeout  = $self->{__daemon}->timeout(1);
        while (! $exit_now)
        {
            $conn = $self->{__daemon}->accept;

            if ($exit_now)
            {
                last;
            }
            if (! $conn)
            {
                next;
            }
            $conn->timeout($self->timeout);
            $self->process_request($conn);

            $eval_return = eval {
                local $SIG{PIPE} = sub { die "server_loop: Caught SIGPIPE\n"; };
                $conn->close;
                1;
            };
            if ((! $eval_return) && $@)
            {
                warn "Cannot close conection: $@\n";
            }

            undef $conn;    # Free up any lingering resources
        }

        if (defined $timeout)
        {
            $self->{__daemon}->timeout($timeout);
        }
    }
    else
    {
        # This is the Net::Server block, but for now HTTP::Daemon is needed
        # for the code that converts socket data to a HTTP::Request object
        require HTTP::Daemon;

        my $conf_file_flag = 0;
        my $port_flag      = 0;
        my $host_flag      = 0;

        # Disable critic on the C-style for-loop because we need to step by
        # 2 as we check for Net::Server arguments...
        for (my $i = 0; $i < @_; $i += 2) ## no critic (ProhibitCStyleForLoops)
        {
            if ($_[$i] eq 'conf_file') { $conf_file_flag = 1; }
            if ($_[$i] eq 'port')      { $port_flag      = 1; }
            if ($_[$i] eq 'host')      { $host_flag      = 1; }
        }

        # An explicitly-given conf-file trumps any specified at creation
        if (exists($self->{conf_file}) and (!$conf_file_flag))
        {
            push @_, 'conf_file', $self->{conf_file};
            $conf_file_flag = 1;
        }

        # Don't do this next part if they've already given a port, or are
        # pointing to a config file:
        if (! ($conf_file_flag || $port_flag))
        {
            push @_, 'port', $self->{port} || $self->port || 9000;
            push @_, 'host', $self->{host} || $self->host || q{*};
        }

        # Try to load the Net::Server::MultiType module
        if (! eval { require Net::Server::MultiType; 1; })
        {
            if ($@)
            {
                return ref($self) .
                    "::server_loop: Error loading Net::Server::MultiType: $@";
            }
        }
        unshift @RPC::XML::Server::ISA, 'Net::Server::MultiType';

        $self->started('set');
        # ...and we're off!
        $self->run(@_);
    }

    return;
}

###############################################################################
#
#   Sub Name:       post_configure_loop
#
#   Description:    Called by the Net::Server classes after all the config
#                   steps have been done and merged.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Class object
#
#   Returns:        $self
#
###############################################################################
sub post_configure_hook
{
    my $self = shift;

    $self->{__host} = $self->{server}->{host};
    $self->{__port} = $self->{server}->{port};

    return $self;
}

###############################################################################
#
#   Sub Name:       pre_loop_hook
#
#   Description:    Called by Net::Server classes after the post_bind method,
#                   but before the socket-accept loop starts.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object instance
#
#   Returns:        $self
#
###############################################################################
sub pre_loop_hook
{
    my $self = shift;

    # We have to disable the __DIE__ handler for the sake of XML::Parser::Expat
    $SIG{__DIE__} = q{}; ## no critic (RequireLocalizedPunctuationVars)

    return $self;
}

###############################################################################
#
#   Sub Name:       process_request
#
#   Description:    This is provided for the case when we run as a subclass
#                   of Net::Server.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       This class object
#                   $conn     in      ref       If present, it's a connection
#                                                 object from HTTP::Daemon
#
#   Returns:        void
#
###############################################################################
sub process_request ## no critic (ProhibitExcessComplexity)
{
    my $self = shift;
    my $conn = shift;

    my (
        $req,     $reqxml,     $resp,     $respxml,  $do_compress,
        $parser,  $com_engine, $length,   $read,     $buf,
        $resp_fh, $tmpdir,     $peeraddr, $peerhost, $peerport
    );

    my $me = ref($self) . '::process_request';
    if (! $conn)
    {
        # Maintain compatibility with Net::Server 0.99, which does not pass
        # the connection object at all:
        $conn = $self->{server}->{client};
    }
    if (ref($conn) =~ /^Net::Server::Proto/)
    {
        bless $conn, 'HTTP::Daemon::ClientConn';
        ${*{$conn}}{'httpd_daemon'} = $self;

        if ($IO::Socket::SSL::VERSION &&
            $RPC::XML::Server::IO_SOCKET_SSL_HACK_NEEDED)
        {
            no strict 'vars'; ## no critic (ProhibitNoStrict)
            # RT 43019: Don't do this if Socket6/IO::Socket::INET6 is in
            # effect, as it causes calls to unpack_sockaddr_in6 to break.
            if (! (defined $Socket6::VERSION ||
                   defined $IO::Socket::INET6::VERSION))
            {
                unshift @HTTP::Daemon::ClientConn::ISA, 'IO::Socket::SSL';
            }

            $RPC::XML::Server::IO_SOCKET_SSL_HACK_NEEDED = 0;
        }
    }

    # These will be attached to any and all request objects that are
    # (successfully) read from $conn.
    $peeraddr = $conn->peeraddr;
    $peerport = $conn->peerport;
    $peerhost = $conn->peerhost;
    while ($conn and $req = $conn->get_request('headers only'))
    {
        if ($req->method eq 'HEAD')
        {
            # The HEAD method will be answered with our return headers,
            # both as a means of self-identification and a verification
            # of live-status. All the headers were pre-set in the cached
            # HTTP::Response object. Also, we don't count this for stats.
            $conn->send_response($self->response);
        }
        elsif ($req->method eq 'POST')
        {
            # Get a XML::Parser::ExpatNB object
            $parser = $self->parser->parse();

            $do_compress = 0; # in case it was set for a previous response
            if (($req->content_encoding || q{}) =~ $self->compress_re)
            {
                if (! $self->compress)
                {
                    $conn->send_error(RC_BAD_REQUEST,
                        "$me: Compression not permitted in " . 'requests');
                    next;
                }

                $do_compress = 1;
            }

            if (($req->content_encoding || q{}) =~ /chunked/i)
            {
                # Technically speaking, we're not supposed to honor chunked
                # transfer-encoding...
                croak "$me: 'chunked' content-encoding not (yet) supported";
            }
            else
            {
                $length = $req->content_length;
                if ($do_compress)
                {
                    # Spin up the compression engine
                    if (! ($com_engine = Compress::Zlib::inflateInit()))
                    {
                        $conn->send_error(RC_INTERNAL_SERVER_ERROR,
                            "$me: Unable to initialize the " .
                                'Compress::Zlib engine');
                        next;
                    }
                }

                $buf = q{};
                while ($length > 0)
                {
                    if ($buf = $conn->read_buffer)
                    {
                        # Anything that get_request read, but didn't use, was
                        # left in the read buffer. The call to sysread() should
                        # NOT be made until we've emptied this source, first.
                        $read = length $buf;
                        $conn->read_buffer(q{}); # Clear it, now that it's read
                    }
                    else
                    {
                        $read = sysread $conn, $buf,
                            ($length < 2048) ? $length : 2048;
                        if (! $read)
                        {
                            # Convert this print to a logging-hook call.
                            # Umm, when I have real logging hooks, I mean.
                            # The point is, odds are very good that $conn is
                            # dead to us now, and I don't want this package
                            # taking over SIGPIPE as well as the ones it
                            # already monopolizes.
                            #print STDERR "Error: Connection Dropped\n";
                            return;
                        }
                    }
                    $length -= $read;
                    if ($do_compress)
                    {
                        if (! ($buf = $com_engine->inflate($buf)))
                        {
                            $conn->send_error(RC_INTERNAL_SERVER_ERROR,
                                "$me: Error inflating " . 'compressed data');
                            # This error also means that even if Keep-Alive
                            # is set, we don't know how much of the stream
                            # is corrupted.
                            $conn->force_last_request;
                            next;
                        }
                    }

                    if (! eval { $parser->parse_more($buf); 1; })
                    {
                        if ($@)
                        {
                            $conn->send_error(
                                RC_INTERNAL_SERVER_ERROR,
                                "$me: Parse error in (compressed) " .
                                "XML request (mid): $@"
                            );
                            # Again, the stream is likely corrupted
                            $conn->force_last_request;
                            next;
                        }
                    }
                }

                if (! eval { $reqxml = $parser->parse_done(); 1; })
                {
                    if ($@)
                    {
                        $conn->send_error(RC_INTERNAL_SERVER_ERROR,
                                          "$me: Parse error in (compressed) " .
                                          "XML request (end): $@");
                        next;
                    }
                }
            }

            # Dispatch will always return a RPC::XML::response.
            # RT29351: If there was an error from RPC::XML::ParserFactory
            # (such as a message that didn't conform to spec), then return it
            # directly as a fault, don't have dispatch() try and handle it.
            if (ref $reqxml)
            {
                # Set localized keys on $self, based on the connection info
                ## no critic (ProhibitLocalVars)
                local $self->{peeraddr} = $peeraddr;
                local $self->{peerhost} = $peerhost;
                local $self->{peerport} = $peerport;
                local $self->{request}  = $req;
                $respxml = $self->dispatch($reqxml);
            }
            else
            {
                $respxml = RPC::XML::response->new(
                    $self->server_fault('badxml', $reqxml));
            }

            # Clone the pre-fab response and set headers
            $resp = $self->response->clone;
            # Should we apply compression to the outgoing response?
            $do_compress = 0;    # In case it was set above for incoming data
            if ($self->compress &&
                ($respxml->length > $self->compress_thresh) &&
                (($req->header('Accept-Encoding') || q{}) =~
                 $self->compress_re))
            {
                $do_compress = 1;
                $resp->header(Content_Encoding => $self->compress);
            }
            # Next step, determine the response disposition. If it is above the
            # threshhold for a requested file cut-off, send it to a temp file
            if ($self->message_file_thresh &&
                $self->message_file_thresh < $respxml->length)
            {
                # Start by creating a temp-file
                $tmpdir = $self->message_temp_dir || File::Spec->tmpdir;
                # File::Temp->new() croaks on error
                $resp_fh =
                    eval { File::Temp->new(UNLINK => 1, DIR => $tmpdir) };
                if (! $resp_fh)
                {
                    $conn->send_error(
                        RC_INTERNAL_SERVER_ERROR,
                        "$me: Error opening tmpfile: $@"
                    );
                    next;
                }
                # Make it auto-flush
                $resp_fh->autoflush();

                # Now that we have it, spool the response to it. This is a
                # little hairy, since we still have to allow for compression.
                # And though the response 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)
                {
                    my $fh_compress =
                        eval { File::Temp->new(UNLINK => 1, DIR => $tmpdir) };
                    if (! $fh_compress)
                    {
                        $conn->send_error(
                            RC_INTERNAL_SERVER_ERROR,
                            "$me: Error opening compression tmpfile: $@"
                        );
                        next;
                    }
                    # Make it auto-flush
                    $fh_compress->autoflush();

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

                    # Spin up the compression engine
                    if (! ($com_engine = Compress::Zlib::deflateInit()))
                    {
                        $conn->send_error(RC_INTERNAL_SERVER_ERROR,
                            "$me: Unable to initialize the " .
                                'Compress::Zlib engine');
                        next;
                    }

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

                    # Close the secondary FH. Rewinding the primary is done
                    # later.
                    if (! close $fh_compress)
                    {
                        carp "Error closing temp file: $!";
                    }
                }
                else
                {
                    $respxml->serialize($resp_fh);
                }
                seek $resp_fh, 0, 0;

                $resp->content_length(-s $resp_fh);
                $resp->content(
                    sub {
                        my $buffer = q{};
                        if (! defined(read $resp_fh, $buffer, 4096))
                        {
                            return;
                        }
                        $buffer;
                    }
                );
            }
            else
            {
                # Treat the content strictly in-memory
                utf8::encode($buf = $respxml->as_string);
                if ($do_compress)
                {
                    $buf = Compress::Zlib::compress($buf);
                }
                $resp->content($buf);
                # With $buf force-downgraded to octets, length() should work
                $resp->content_length(length $buf);
            }

            my $eval = eval {
                local $SIG{PIPE} = sub { die "Caught SIGPIPE\n"; };
                $conn->send_response($resp);
                1;
            };
            if (! $eval && $@ && $@ =~ /Caught SIGPIPE/)
            {
                # Client disconnected, maybe even before we started sending
                # our response. Either way, $conn is useless now.
                undef $conn;
            }
            undef $resp;
        }
        else
        {
            $conn->send_error(RC_FORBIDDEN);
        }
    }

    return;
}

###############################################################################
#
#   Sub Name:       dispatch
#
#   Description:    Route the request by parsing it, determining what the
#                   Perl routine should be, etc.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $xml      in      ref       Reference to the XML text, or
#                                                 a RPC::XML::request object.
#                                                 If it is a listref, assume
#                                                 [ name, @args ].
#                   $reftable in      hashref   If present, a reference to the
#                                                 current-running table of
#                                                 back-references
#
#   Returns:        RPC::XML::response object
#
###############################################################################
sub dispatch
{
    my ($self, $xml) = @_;

    my ($reqobj, @args, $response, $name, $meth);

    if (ref $xml eq 'SCALAR')
    {
        $reqobj = $self->parser->parse(${$xml});
        if (! ref $reqobj)
        {
            return RPC::XML::response->
                new($self->server_fault(badxml => $reqobj));
        }
    }
    elsif (ref $xml eq 'ARRAY')
    {
        # This is sort of a cheat, to make the system.multicall API call a
        # lot easier. The syntax isn't documented in the manual page, for good
        # reason.
        $reqobj = RPC::XML::request->new(@{$xml});
    }
    elsif (blessed $xml && $xml->isa('RPC::XML::request'))
    {
        $reqobj = $xml;
    }
    else
    {
        $reqobj = $self->parser->parse($xml);
        if (! ref $reqobj)
        {
            return RPC::XML::response->
                new($self->server_fault(badxml => $reqobj));
        }
    }

    @args = @{$reqobj->args};
    $name = $reqobj->name;

    # Get the method, call it, and bump the internal requests counter. Create
    # a fault object if there is problem with the method object itself.
    $meth = $self->get_method($name);
    if (ref $meth)
    {
        $response = $meth->call($self, @args);
        if (! (($name eq 'system.status') &&
               @args &&
               ($args[0]->type eq 'boolean') &&
               ($args[0]->value)))
        {
            $self->{__requests}++;
        }
    }
    else
    {
        $response = $self->server_fault(
            badmethod => "No method '$meth' on server"
        );
    }

    # All the eval'ing and error-trapping happened within the method class
    return RPC::XML::response->new($response);
}

###############################################################################
#
#   Sub Name:       call
#
#   Description:    This is an internal, end-run-around-dispatch() method to
#                   allow the RPC methods that this server has and knows about
#                   to call each other through their reference to the server
#                   object.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $name     in      scalar    Name of the method to call
#                   @args     in      list      Arguments (if any) to pass
#
#   Returns:        Success:    return value of the call
#                   Failure:    error string
#
###############################################################################
sub call
{
    my ($self, $name, @args) = @_;

    my $meth;

    # Two VERY important notes here: The values in @args are not pre-treated
    # in any way, so not only should the receiver understand what they're
    # getting, there's no signature checking taking place, either.
    #
    # Second, if the normal return value is not distinguishable from a string,
    # then the caller may not recognize if an error occurs.

    $meth = $self->get_method($name);
    if (! ref $meth)
    {
        return $meth;
    }

    return $meth->call($self, @args);
}

###############################################################################
#
#   Sub Name:       add_default_methods
#
#   Description:    This adds all the methods that were shipped with this
#                   package, by threading through to add_methods_in_dir()
#                   with the global constant $INSTALL_DIR.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object reference/static class
#                   @details  in      ref       Details of names to add or skip
#
#   Returns:        $self
#
###############################################################################
sub add_default_methods
{
    my ($self, @details) = @_;

    return $self->add_methods_in_dir($self->INSTALL_DIR, @details);
}

###############################################################################
#
#   Sub Name:       add_methods_in_dir
#
#   Description:    This adds all methods specified in the directory passed,
#                   in accordance with the details specified.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Class instance
#                   $dir      in      scalar    Directory to scan
#                   @details  in      list      Possible hanky-panky with the
#                                                 list of methods to install
#
#   Returns:        $self
#
###############################################################################
sub add_methods_in_dir
{
    my ($self, $dir, @details) = @_;

    my $negate = 0;
    my $detail = 0;
    my (%details, $ret);

    if (@details)
    {
        $detail = 1;
        if ($details[0] =~ /^-?except/i)
        {
            $negate = 1;
            shift @details;
        }
        for (@details)
        {
            if (! /[.]xpl$/)
            {
                $_ .= '.xpl';
            }
        }
        @details{@details} = (1) x @details;
    }

    my $dh;
    if (! opendir $dh, $dir)
    {
        return "Error opening $dir for reading: $!";
    }
    my @files = grep { $_ =~ /[.]xpl$/ } readdir $dh;
    closedir $dh;

    for my $file (@files)
    {
        # Use $detail as a short-circuit to avoid the other tests when we can
        if ($detail &&
            ($negate ? $details{$file} : ! $details{$file}))
        {
            next;
        }
        # n.b.: Giving the full path keeps add_method from having to search
        $ret = $self->add_method(File::Spec->catfile($dir, $file));
        if (! ref $ret)
        {
            return $ret;
        }
    }

    return $self;
}

# For name-symmetry:
*add_procedures_in_dir = *add_functions_in_dir = \&add_methods_in_dir;

###############################################################################
#
#   Sub Name:       delete_method
#
#   Description:    Remove any current binding for the named method on the
#                   calling server object. Note that if this method is shared
#                   across other server objects, it won't be destroyed until
#                   the last server deletes it.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $name     in      scalar    Name of method to lost
#
#   Returns:        Success:    $self
#                   Failure:    error message
#
###############################################################################
sub delete_method
{
    my ($self, $name) = @_;

    if ($name)
    {
        if ($self->{__method_table}->{$name})
        {
            delete $self->{__method_table}->{$name};
        }
    }
    else
    {
        return ref $self . "::delete_method: No such method $name";
    }

    return $self;
}

# For name-symmetry:
*delete_procedure = *delete_function = \&delete_method;

###############################################################################
#
#   Sub Name:       list_methods
#
#   Description:    Return a list of the methods this object has published.
#                   Returns the names, not the objects.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#
#   Returns:        List of names, possibly empty
#
###############################################################################
sub list_methods
{
    return keys %{shift->{__method_table}};
}

# For name-symmetry:
*list_procedures = *list_functions = \&list_methods;

###############################################################################
#
#   Sub Name:       share_methods
#
#   Description:    Share the named methods as found on $src_srv into the
#                   method table of the calling object.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $src_srv  in      ref       Another object of this class
#                   @names    in      list      One or more method names
#
#   Returns:        Success:    $self
#                   Failure:    error message
#
###############################################################################
sub share_methods
{
    my ($self, $src_srv, @names) = @_;

    my ($me, $pkg, %methods, @methods, $meth, @list, @missing);

    $me  = ref($self) . '::share_methods';
    $pkg = __PACKAGE__; # So it can go inside quoted strings

    if (! (blessed $src_srv && $src_srv->isa($pkg)))
    {
        return "$me: First arg not derived from $pkg, cannot share";
    }
    if (! @names)
    {
        return "$me: Must specify at least one method name for sharing";
    }

    # Scan @names for any regex objects, and if found insert the matches into
    # the list.
    #
    # Only do this once:
    @methods = keys %{$src_srv->{__method_table}};
    for my $name (@names)
    {
        if (ref $name eq 'Regexp')
        {
            for (grep { $_ =~ $name } @methods)
            {
                $methods{$_}++;
            }
        }
        else
        {
            $methods{$name}++;
        }
    }
    # This has the benefit of trimming any redundancies caused by regex's
    @names = keys %methods;

    # Note that the method refs are saved until we've verified all of them.
    # If we have to return a failure message, I don't want to leave a half-
    # finished job or have to go back and undo (n-1) additions because of one
    # failure.
    for (@names)
    {
        $meth = $src_srv->get_method($_);
        if (ref $meth)
        {
            push @list, $meth;
        }
        else
        {
            push @missing, $_;
        }
    }

    if (@missing)
    {
        return "$me: One or more methods not found on source object: " .
            join q{ } => @missing;
    }
    else
    {
        for (@list)
        {
            $self->add_method($_);
        }
    }

    return $self;
}

# For name-symmetry:
*share_procedures = *share_functions = \&share_methods;

###############################################################################
#
#   Sub Name:       copy_methods
#
#   Description:    Copy the named methods as found on $src_srv into the
#                   method table of the calling object. This differs from
#                   share() above in that only the coderef is shared, the
#                   rest of the method is a completely new object.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $src_srv  in      ref       Another object of this class
#                   @names    in      list      One or more method names
#
#   Returns:        Success:    $self
#                   Failure:    error message
#
###############################################################################
sub copy_methods
{
    my ($self, $src_srv, @names) = @_;

    my ($me, $pkg, %methods, @methods, $meth, @list, @missing);

    $me  = ref($self) . '::copy_methods';
    $pkg = __PACKAGE__; # So it can go inside quoted strings

    if (! (blessed $src_srv && $src_srv->isa($pkg)))
    {
        return "$me: First arg not derived from $pkg, cannot copy";
    }
    if (! @names)
    {
        return "$me: Must specify at least one method name/regex for copying";
    }

    # Scan @names for any regez objects, and if found insert the matches into
    # the list.
    #
    # Only do this once:
    @methods = keys %{$src_srv->{__method_table}};
    for my $name (@names)
    {
        if (ref $name eq 'Regexp')
        {
            for (grep { $_ =~ $name } @methods)
            {
                $methods{$_}++;
            }
        }
        else
        {
            $methods{$name}++;
        }
    }
    # This has the benefit of trimming any redundancies caused by regex's
    @names = keys %methods;

    # Note that the method clones are saved until we've verified all of them.
    # If we have to return a failure message, I don't want to leave a half-
    # finished job or have to go back and undo (n-1) additions because of one
    # failure.
    for (@names)
    {
        $meth = $src_srv->get_method($_);
        if (ref $meth)
        {
            push @list, $meth->clone;
        }
        else
        {
            push @missing, $_;
        }
    }

    if (@missing)
    {
        return "$me: One or more methods not found on source object: @missing";
    }
    else
    {
        for (@list)
        {
            $self->add_method($_);
        }
    }

    return $self;
}

# For name-symmetry:
*copy_procedures = *copy_functions = \©_methods;

###############################################################################
#
#   Sub Name:       timeout
#
#   Description:    This sets the timeout for processing connections after
#                   a new connection has been accepted.  It returns the old
#                   timeout value.  If you pass in no value, it returns
#                   the current timeout.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object reference/static class
#                   $timeout  in      ref       New timeout value
#
#   Returns:        $self->{__timeout}
#
###############################################################################
sub timeout
{
    my ($self, $timeout) = @_;

    my $old_timeout = $self->{__timeout};
    if ($timeout)
    {
        $self->{__timeout} = $timeout;
    }

    return $old_timeout;
}

###############################################################################
#
#   Sub Name:       server_fault
#
#   Description:    Create a RPC::XML::fault object for the class of error
#                   and specific message that are passed in.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $err      in      scalar    Type of error/fault to generate
#                   $message  in      scalar    Error text for the fault
#
#   Returns:        RPC::XML::fault instance
#
###############################################################################
sub server_fault
{
    my ($self, $err, $message) = @_;
    $message ||= q{}; # Avoid any "undef" warnings

    my ($code, $text);

    if (my $fault = $self->{__fault_table}->{$err})
    {
        if (ref $fault)
        {
            # This specifies both code and message
            ($code, $text) = @{$fault};
            # Replace (the first) "%s" with $message
            $text =~ s/%s/$message/;
        }
        else
        {
            # This is just the code, use $message verbatim
            ($code, $text) = ($fault, $message);
        }
    }
    else
    {
        $code = -1;
        $text = "Unknown error class '$err' (message is '$message')";
    }

    return RPC::XML::fault->new($code, $text);
}

1;

__END__