package JSON::RPC::Server::Daemon;

use strict;
use JSON::RPC::Server; # for old Perl 5.005
use base qw(JSON::RPC::Server);

$JSON::RPC::Server::Daemon::VERSION = '0.03';

use Data::Dumper;

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new();
    my $pkg;

    if(  grep { $_ =~ /^SSL_/ } @_ ){
        $self->{_daemon_pkg} = $pkg = 'HTTP::Daemon::SSL';
    }
    else{
        $self->{_daemon_pkg} = $pkg = 'HTTP::Daemon';
    }
    eval qq| require $pkg; |;
    if($@){ die $@ }

    $self->{_daemon} ||= $pkg->new(@_) or die;

    return $self;
}


sub handle {
    my $self = shift;
    my %opt  = @_;
    my $d    = $self->{_daemon} ||= $self->{_daemon_pkg}->new(@_) or die;

    while (my $c = $d->accept) {
        $self->{con} = $c;
        while (my $r = $c->get_request) {
            $self->request($r);
            $self->path_info($r->url->path);
            $self->SUPER::handle();
            last;
        }
        $c->close;
    }

}


##</code><code>##

package RPC::XML::Server;

use 5.006001;
use strict;
use warnings;
use vars qw($VERSION @ISA $INSTANCE $INSTALL_DIR %FAULT_TABLE  @XPL_PATH
            $IO_SOCKET_SSL_HACK_NEEDED $COMPRESSION_AVAILABLE);

use Carp qw(carp croak);
use AutoLoader 'AUTOLOAD';
use File::Spec;
use IO::Handle;

use HTTP::Status;
use HTTP::Response;
use URI;
use Scalar::Util 'blessed';

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

....

sub new ## no critic (ProhibitExcessComplexity)
{
    my ($class, %args) = @_;

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

    $class = ref($class) || $class;
    $self = bless {}, $class;

    $srv_version = delete $args{server_version} || $self->version;
    $srv_name    = delete $args{server_name}    || $class;
    $self->{__version} = "$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();
    if (! $resp)
    {
        return "${class}::new: Unable to create HTTP::Response object";
    }

    $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->{__version},
        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}} : ());

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

    # Compression support
    $self->{__compress} = q{};
    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} = {%FAULT_TABLE};
    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}})
        {
            if (ref($self->{__fault_table}->{$key}))
            {
                # A ref is a listref where the first element is the code
                $self->{__fault_table}->{$key}->[0] += $base;
            }
            else
            {
                $self->{__fault_table}->{$key} += $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;
}

...

###############################################################################
#
#   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);

        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);
            $conn->close;
            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;
}