#
# 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.15';
}

use strict;
use warnings;
use PerlIO::via::TimeoutWithReset;
use PerlIO::via::Timeout qw(:all);

use Carp;

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


our $DEFAULT_STRATEGY = 'Select';

sub new::with::timeout {
    my $class = shift
      or croak "needs a class name. Try IO::Socket::INET->new::with::timeout(...)";

    my $class_file = $class;
    $class_file =~ s!::|'!/!g;
    $class_file .= '.pm';
    require $class_file;

    $class->isa('IO::Socket')
      or croak 'new::with::timeout can be used only on classes that isa IO::Socket';

    # if arguments are not key values, just original class constructor
    @_ % 2
      and return $class->new(@_);

    my %args = @_;

    my $read_timeout = delete $args{ReadTimeout};
    my $write_timeout = delete $args{WriteTimeout};
    if (defined (my $readwrite_timeout = delete $args{ReadWriteTimeout})) {
        $read_timeout = $write_timeout = $readwrite_timeout;
    }
    
    # if no timeout feature is used, just call original class constructor
    $read_timeout && $read_timeout > 0 || $write_timeout && $write_timeout > 0
      or return $class->new(%args);

    my $socket = $class->new(%args);

    binmode($socket, ':via(TimeoutWithReset)');
    $read_timeout && $read_timeout > 0
      and read_timeout($socket, $read_timeout);
    $write_timeout && $write_timeout > 0
      and write_timeout($socket, $write_timeout);
    return $socket;
}

sub socketpair::with::timeout {
    my $class = shift
      or croak "needs a class name. Try IO::Socket::INET->socketpair::with::timeout(...)";

    my $class_file = $class;
    $class_file =~ s!::|'!/!g;
    $class_file .= '.pm';
    require $class_file;

    $class->isa('IO::Socket')
      or croak 'new::with::timeout can be used only on classes that isa IO::Socket';

    # we expect DOMAIN, TYPE, PROTOCOL, TIMEOUT_ARGS. Otherwise just call original
    @_ == 4
      or return $class->socketpair(@_);

    my $timeout_args = pop;

    my %args = %$timeout_args;
    my $read_timeout = delete $args{ReadTimeout};
    my $write_timeout = delete $args{WriteTimeout};
    if (defined (my $readwrite_timeout = delete $args{ReadWriteTimeout})) {
        $read_timeout = $write_timeout = $readwrite_timeout;
    }

    # if no timeout feature is used, just call original class constructor
    $read_timeout && $read_timeout > 0 || $write_timeout && $write_timeout > 0
      or return $class->socketpair(@_);

    my ($socket1, $socket2) = $class->socketpair(@_)
       or return;


    foreach my $socket ($socket1, $socket2) {
        binmode($socket, ':via(TimeoutWithReset)');
        $read_timeout && $read_timeout > 0
          and read_timeout($socket, $read_timeout);
        $write_timeout && $write_timeout > 0
          and write_timeout($socket, $write_timeout);
    }
    return ($socket1, $socket2);
}

1;

__END__
=pod

=head1 NAME

IO::Socket::Timeout - IO::Socket with read/write timeout

=head1 VERSION

version 0.15

=head1 SYNOPSIS

  use IO::Socket::With::Timeout;

  # creates a IO::Socket::INET::With::Timeout object
  my $socket = IO::Socket::INET->new::with::timeout( Timeout => 2,
                                                     ReadTimeout => 0.5,
                                                     # other standard arguments );

  my $socket = IO::Socket::UNIX->new::with::timeout( Timeout => 2,
                                                     ReadTimeout => 0.5,
                                                     WriteTimeout => 0.5,
                                                     # other standard arguments );

  my $socket = IO::Socket::INET->new::with::timeout( Timeout => 2,
                                                     ReadWriteTimeout => 0.5,
                                                     # other standard arguments );

  # When using the socket:
  use Errno qw(ETIMEDOUT);
  print $socket $request;
  my $response = <$socket>;
  if (!defined $response && 0+$! == ETIMEDOUT) {
    die "timeout reading on the socket";
  }

=head1 DESCRIPTION

C<IO::Socket> provides a way to set a timeout on the socket, but the timeout
will be used only for connection, not for reading / writing operations.

This module provides a way to set a timeout on read / write operations on an
C<IO::Socket> instance, or any C<IO::Socket::*> modules, like
C<IO::Socket::INET>.

=head1 CONSTRUCTORS

=head2 new::with::timeout

To be able to work with any class that is or inherits from IO::Socket, the
interface of this module is a bit unusual.

C<IO::Socket::INET->new::with::timeout(...)> will return an instance of
C<IO::Socket::INET>, as if it had been called with
C<IO::Socket::INET->new(...)>. However, it'll apply some mechanism on the
resulting socket object so that it times out on read, write, or both.

The way the socket will timeout ( on connection, read, write, how long), can be
specified with these parameters:

=over

=item Timeout

This is the default parameter that already exists in IO::Socket. If set to a
value, the socket will timeout at B<connection time>.

=item ReadTimeout

If set to a value, the socket will timeout on reads. Value is in seconds, floats
accepted.

=item WriteTimeout

If set to a value, the socket will timeout on writes. Value is in seconds, floats
accepted.

=item ReadWriteTimeout

If set to a value, the socket will timeout on reads and writes. Value is in seconds, floats
accepted. If set, this option superseeds ReadTimeout and WriteTimeout.

=back

=head2 socketpair::with::timeout

There is an other way to create sockets from scratch, via C<socketpair>. As for
the C<new> constructor, this module provides its counterpart with timeout
feature.

C<IO::Socket::INET->socketpair::with::timeout(...)> will return two instances of
C<IO::Socket::INET>, as if it had been called with
C<IO::Socket::INET->socketpair(...)>. However, it'll apply some mechanism on the
resulting socket object so that it times out on read, write, or both.

=head1 CHANGE SETTINGS AFTER CREATION

You can change the timeout settings of a socket after it has been instanciated.
These functions are part of L<PerlIO::via::Timeout>. Check its documentation
for more details.

  use IO::Socket::With::Timeout;
  # create a socket with read timeout
  my $socket = IO::Socket::INET->new::with::timeout( Timeout => 2,
                                                     ReadTimeout => 0.5,
                                                     # other standard arguments );

  use PerlIO::via::Timeout qw(:all);
  # change read_timeout to 5 and write timeout to 1.5 sec
  read_timeout($socket, 5)
  write_timeout($socket, 1.5)
  # actually disable the timeout for now
  disable_timeout($socket)
  # when re-enabling it, timeouts value are restored
  enable_timeout($socket)

=head1 WHEN TIMEOUT IS HIT

When a timeout (read, write) is hit on the socket, the function trying to be
performed will return C<undef>, and C<$!> will be set to C<ETIMEOUT>.

The socket will be marked as invalid internally, and any subsequential use of
it will return C<undef>, and $! will be set to C<ECONNRESET>.

Why invalid the socket ? If you read a socket, waiting for message A, and hit a
timeout, if you then reuse the socket to read a message B, you might receive
the answer A instead. There is no way to properly discard the first message,
because the sender mught not be reachable (that's probably why you got a
timeout in the first place). So after a timeout failure, it's important that
you recreate the socket.

You can import ETIMEOUT and ECONNRESET by using C<POSIX>:

  use Errno qw(ETIMEDOUT ECONNRESET);

=head1 IF YOU NEED TO RETRY

If you want to implement a try / wait / retry mechanism, I recommend using a
third-party module, like C<Action::Retry>. Something like this:

  my $socket;

  my $answer;
  my $action = Action::Retry->new(
    attempt_code => sub {
        # (re-)create the socket if needed
        $socket && ! $socket->error
          or $socket = IO::Socket->new::with::timeout(ReadTimeout => 0.5);
        # send the request, read the answer
        $socket->print($_[0]);
        defined($answer = $socket->getline) or die $!;
        $answer;
    },
    on_failure_code => sub { die 'aborting, to many retries' },
  );

  my $reply = $action->run('GET mykey');

=head1 SEE ALSO

L<Action::Retry>, L<IO::Select>, L<PerlIO::via::Timeout>, L<Time::Out>

=head1 THANKS

Thanks to Vincent Pitt, Christian Hansen and Toby Inkster for various help and
useful remarks.

=head1 AUTHOR

Damien "dams" Krotkine

=head1 COPYRIGHT AND LICENSE

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.

=cut

