File Coverage

blib/lib/IO/Socket/Timeout.pm

Criterion	Covered	Total	%
statement	112	122	91.8
branch	23	36	63.8
condition	24	40	60.0
subroutine	23	27	85.1
pod	1	1	100.0
total	183	226	80.9

#
# This file is part of IO-Socket-Timeout
#
# This software is copyright (c) 2013 by Damien "dams" Krotkine.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package IO::Socket::Timeout;
$IO::Socket::Timeout::VERSION = '0.32';
use strict;
use warnings;
use Config;
use Carp;


# ABSTRACT: IO::Socket with read/write timeout


sub import {
    shift;
    foreach (@_) {
        _create_composed_class( $_, 'IO::Socket::Timeout::Role::SetSockOpt');
        _create_composed_class( $_, 'IO::Socket::Timeout::Role::PerlIO');
    }
}


sub enable_timeouts_on {
    my ($class, $socket) = @_;
    defined $socket
      or return;
    $socket->isa('IO::Socket')
      or croak 'make_timeouts_aware can be used only on instances that inherit from IO::Socket';

    my $osname = $Config{osname};
    if ( ! $ENV{PERL_IO_SOCKET_TIMEOUT_FORCE_SELECT}
         && ( $osname eq 'darwin' || $osname eq 'linux' || $osname eq 'freebsd' ) ) {
        _compose_roles($socket, 'IO::Socket::Timeout::Role::SetSockOpt');
    } else {
        require PerlIO::via::Timeout;
        binmode($socket, ':via(Timeout)');
        _compose_roles($socket, 'IO::Socket::Timeout::Role::PerlIO');
    }

    $socket->enable_timeout;
    return $socket;
}

sub _create_composed_class {
    my ($class, @roles) = @_;
    my $composed_class = $class . '__with__' . join('__and__', @roles);
    my $path = $composed_class; $path =~ s|::|/|g; $path .= '.pm';
    if ( ! exists $INC{$path}) {
        no strict 'refs';
        *{"${composed_class}::ISA"} = [ $class, @roles ];
        $INC{$path} = __FILE__;
    }
    return $composed_class;
}

sub _compose_roles {
    my ($instance, @roles) = @_;
    bless $instance, _create_composed_class(ref $instance, @roles);
}

# sysread FILEHANDLE,SCALAR,LENGTH,OFFSET
BEGIN {
    my $osname = $Config{osname};
    if ( $ENV{PERL_IO_SOCKET_TIMEOUT_FORCE_SELECT} ||
         $osname ne 'darwin' && $osname ne 'linux' && $osname ne 'freebsd'
       ) {
        # this variable avoids infinite recursion, because
        # PerlIO::via::Timeout->READ calls sysread.
        my $_prevent_deep_recursion;
        *CORE::GLOBAL::sysread = sub {
            my $args_count = scalar(@_);
               $_prevent_deep_recursion
            || ! PerlIO::via::Timeout::has_timeout_layer($_[0])
            || ! PerlIO::via::Timeout::timeout_enabled($_[0])
              and return (  $args_count == 4 ? CORE::sysread($_[0], $_[1], $_[2], $_[3])
                          :                    CORE::sysread($_[0], $_[1], $_[2])
                         );
            $_prevent_deep_recursion = 1;
            my $ret_val = PerlIO::via::Timeout->READ($_[1], $_[2], $_[0]);
            $_prevent_deep_recursion = 0;
            return $ret_val;
        }
    }
}

# syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET
BEGIN {
    my $osname = $Config{osname};
    if ( $ENV{PERL_IO_SOCKET_TIMEOUT_FORCE_SELECT} ||
         $osname ne 'darwin' && $osname ne 'linux' && $osname ne 'freebsd'
       ) {
        # this variable avoids infinite recursion, because
        # PerlIO::via::Timeout->WRITE calls syswrite.
        my $_prevent_deep_recursion;
        *CORE::GLOBAL::syswrite = sub {
            my $args_count = scalar(@_);
               $_prevent_deep_recursion
            || ! PerlIO::via::Timeout::has_timeout_layer($_[0])
            || ! PerlIO::via::Timeout::timeout_enabled($_[0])
              and return(   $args_count == 4 ? CORE::syswrite($_[0], $_[1], $_[2], $_[3])
                          : $args_count == 3 ? CORE::syswrite($_[0], $_[1], $_[2])
                          :                    CORE::syswrite($_[0], $_[1])
                        );
            $_prevent_deep_recursion = 1;
            my $ret_val = PerlIO::via::Timeout->WRITE($_[1], $_[0]);
            $_prevent_deep_recursion = 0;
            return $ret_val;
        }
    }
}

package IO::Socket::Timeout::Role::SetSockOpt;
$IO::Socket::Timeout::Role::SetSockOpt::VERSION = '0.32';
use Carp;
use Socket;

sub _check_attributes {
    my ($self) = @_;
    grep { $_ < 0 } grep { defined } map { ${*$self}{$_} } qw(ReadTimeout WriteTimeout)
      and croak "if defined, 'ReadTimeout' and 'WriteTimeout' attributes should be >= 0";
}

sub read_timeout {
    my ($self) = @_;
    @_ > 1 and ${*$self}{ReadTimeout} = $_[1], $self->_check_attributes, $self->_set_sock_opt;
    ${*$self}{ReadTimeout}
}

sub write_timeout {
    my ($self) = @_;
    @_ > 1 and ${*$self}{WriteTimeout} = $_[1], $self->_check_attributes, $self->_set_sock_opt;
    ${*$self}{WriteTimeout}
}

sub enable_timeout { $_[0]->timeout_enabled(1) }
sub disable_timeout { $_[0]->timeout_enabled(0) }
sub timeout_enabled {
    my ($self) = @_;
    @_ > 1 and ${*$self}{TimeoutEnabled} = !!$_[1], $self->_set_sock_opt;
    ${*$self}{TimeoutEnabled}
}

sub _set_sock_opt {
    my ($self) = @_;
    my $read_seconds;
    my $read_useconds;
    my $write_seconds;
    my $write_useconds;
    if (${*$self}{TimeoutEnabled}) {
        my $read_timeout = ${*$self}{ReadTimeout} || 0;
        $read_seconds  = int( $read_timeout );
        $read_useconds = int( 1_000_000 * ( $read_timeout - $read_seconds ));
        my $write_timeout = ${*$self}{WriteTimeout} || 0;
        $write_seconds  = int( $write_timeout );
        $write_useconds = int( 1_000_000 * ( $write_timeout - $write_seconds ));
    } else {
        $read_seconds  = 0; $read_useconds  = 0;
        $write_seconds = 0; $write_useconds = 0;
    }
    my $read_struct  = pack( 'l!l!', $read_seconds, $read_useconds );
    my $write_struct = pack( 'l!l!', $write_seconds, $write_useconds );

    $self->setsockopt( SOL_SOCKET, SO_RCVTIMEO, $read_struct )
      or croak "setsockopt(SO_RCVTIMEO): $!";

    $self->setsockopt( SOL_SOCKET, SO_SNDTIMEO, $write_struct )
      or croak "setsockopt(SO_SNDTIMEO): $!";
}

package IO::Socket::Timeout::Role::PerlIO;
$IO::Socket::Timeout::Role::PerlIO::VERSION = '0.32';
use PerlIO::via::Timeout;

sub read_timeout    { goto &PerlIO::via::Timeout::read_timeout    }
sub write_timeout   { goto &PerlIO::via::Timeout::write_timeout   }
sub enable_timeout  { goto &PerlIO::via::Timeout::enable_timeout  }
sub disable_timeout { goto &PerlIO::via::Timeout::disable_timeout }
sub timeout_enabled { goto &PerlIO::via::Timeout::timeout_enabled }

1;

__END__