File Coverage

blib/lib/XAS/Lib/Mixins/Keepalive.pm

Criterion	Covered	Total	%
statement	9	39	23.0
branch	0	14	0.0
condition			n/a
subroutine	3	7	42.8
pod	2	2	100.0
total	14	62	22.5

package XAS::Lib::Mixins::Keepalive;

our $VERSION = '0.01';

our $TCP_KEEPCNT = 0;
our $TCP_KEEPIDLE = 0;
our $TCP_KEEPINTVL = 0;

use Try::Tiny;
use Socket ':all';

use XAS::Class
  debug     => 0,
  version   => $VERSION,
  base      => 'XAS::Base',
  utils     => ':validation',
  accessors => 'tcp_keepidle tcp_keepcnt tcp_keepintvl',
  mixins    => 'init_keepalive enable_keepalive tcp_keepidle tcp_keepcnt tcp_keepintvl',
;

# ----------------------------------------------------------------------
# Public Methods
# ----------------------------------------------------------------------

sub enable_keepalive {
    my $self = shift;
    my ($socket) = validate_params(\@_, [1]);

    # turn keepalive on, this should send a keepalive
    # packet once every 2 hours according to the RFC.

    setsockopt($socket, SOL_SOCKET, SO_KEEPALIVE,  1);

    # adjust the system defaults, all values are in seconds.
    # so this does the following:
    #   every 15 minutes send up to 3 packets at 5 second intervals
    #     if no reply, the connection is down.

    setsockopt($socket, IPPROTO_TCP, $TCP_KEEPINTVL, $self->tcp_keepintvl);
    setsockopt($socket, IPPROTO_TCP, $TCP_KEEPIDLE,  $self->tcp_keepidle);
    setsockopt($socket, IPPROTO_TCP, $TCP_KEEPCNT,   $self->tcp_keepcnt);

}

# ----------------------------------------------------------------------
# Private Methods
# ----------------------------------------------------------------------

sub init_keepalive {
    my $self = shift;
    my $p = validate_params(\@_, {
        -tcp_keepcnt   => { optional => 1, default => 3 },   # number of packets
        -tcp_keepidle  => { optional => 1, default => 900 }, # 15 minutes
        -tcp_keepintvl => { optional => 1, default => 5 },   # interval seconds
    });

    $self->{tcp_keepcnt}   = $p->{tcp_keepcnt};
    $self->{tcp_keepidle}  = $p->{tcp_keepidle};
    $self->{tcp_keepintvl} = $p->{tcp_keepintvl};

    # implement socket level keepalive, what a mess...

    if ( $] < 5.014 ) {               # check perl's version

        # at this point we can only support the below. if you have
        # access to your systems header files, you could provide
        # the following values. I would be happy to include them.

        if ($^O eq "aix") {         # from /usr/include/netinet/tcp.h

            $TCP_KEEPIDLE  = 0x11;
            $TCP_KEEPINTVL = 0x12;
            $TCP_KEEPCNT   = 0x13;

        } elsif ($^O eq "linux") {  # from /usr/include/netinet/tcp.h

            $TCP_KEEPIDLE  = 4;
            $TCP_KEEPINTVL = 5;
            $TCP_KEEPCNT   = 6;

        } elsif ($^O eq 'vms') {    # from TCP in sys$library:decc$rtldef.tlb

            $TCP_KEEPIDLE  = 0x04;
            $TCP_KEEPINTVL = 0x05;
            $TCP_KEEPCNT   = 0x06;

        }

    } else {

        try {

            # hmmm, maybe perl will do it for us. checking to see if the
            # platform implements these macros.

            $TCP_KEEPCNT   = Socket::TCP_KEEPCNT()   if (UNIVERSAL::can('Socket', 'TCP_KEEPCNT'));
            $TCP_KEEPIDLE  = Socket::TCP_KEEPIDLE()  if (UNIVERSAL::can('Socket', 'TCP_KEEPIDLE'));
            $TCP_KEEPINTVL = Socket::TCP_KEEPINTVL() if (UNIVERSAL::can('Socket', 'TCP_KEEPINTVL'));

        } catch {

            # nope, guess not...

            my $ex = $_;
            my ($err) = m/(.*,)/;
            chop($err);

            $self->log->warn(lcfirst($err));

        };

    }

}

1;

__END__