File Coverage

blib/lib/PerlIO/via/Timeout.pm

Criterion	Covered	Total	%
statement	83	92	90.2
branch	20	40	50.0
condition	18	39	46.1
subroutine	19	20	95.0
pod	5	7	71.4
total	145	198	73.2

#
# This file is part of PerlIO-via-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 PerlIO::via::Timeout;
{
  $PerlIO::via::Timeout::VERSION = '0.29';
}

# ABSTRACT: a PerlIO layer that adds read & write timeout to a handle

require 5.008;
use strict;
use warnings;
use Carp;
use Errno qw(EBADF EINTR ETIMEDOUT);
use Scalar::Util qw(reftype blessed weaken);

use Exporter 'import'; # gives you Exporter's import() method directly

our @EXPORT_OK = qw(read_timeout write_timeout enable_timeout disable_timeout timeout_enabled);

our %EXPORT_TAGS = (all => [@EXPORT_OK]);


sub _get_fd {
    # params: FH
    $_[0] or return;
    my $fd = fileno $_[0];
    defined $fd && $fd >= 0
      or return;
    $fd;
}

my %fd2prop;

sub _fh2prop {
    # params: self, $fh
    my $prop = $fd2prop{ my $fd = _get_fd $_[1]
                         or croak 'failed to get file descriptor for filehandle' };
    wantarray and return ($prop, $fd);
    return $prop;
}

sub PUSHED {
    # params CLASS, MODE, FH
    $fd2prop{_get_fd $_[2]} = { timeout_enabled => 1, read_timeout => 0, write_timeout => 0};
    bless {}, $_[0];
}

sub POPPED {
    # params: SELF [, FH ]
    delete $fd2prop{_get_fd($_[1]) or return};
}

sub CLOSE {
    # params: SELF, FH
    delete $fd2prop{_get_fd($_[1]) or return -1};
    close $_[1] or -1;
}

sub READ {
    # params: SELF, BUF, LEN, FH
    my ($self, undef, $len, $fh) = @_;

    # There is a bug in PerlIO::via (possibly in PerlIO ?). We would like
    # to return -1 to signify error, but doing so doesn't work (it usually
    # segfault), it looks like the implementation is not complete. So we
    # return 0.
    my ($prop, $fd) = __PACKAGE__->_fh2prop($fh);

    my $timeout_enabled = $prop->{timeout_enabled};
    my $read_timeout    = $prop->{read_timeout};

    my $offset = 0;
    while ($len) {
        if ( $timeout_enabled && $read_timeout && $len && ! _can_read_write($fh, $fd, $read_timeout, 0)) {
            $! ||= ETIMEDOUT;
            return 0;
        }
        my $r = sysread($fh, $_[1], $len, $offset);
        if (defined $r) {
            last unless $r;
            $len -= $r;
            $offset += $r;
        }
        elsif ($! != EINTR) {
            # There is a bug in PerlIO::via (possibly in PerlIO ?). We would like
            # to return -1 to signify error, but doing so doesn't work (it usually
            # segfault), it looks like the implementation is not complete. So we
            # return 0.
            return 0;
        }
    }
    return $offset;
}

sub WRITE {
    # params: SELF, BUF, FH
    my ($self, undef, $fh) = @_;

    my ($prop, $fd) = __PACKAGE__->_fh2prop($fh);

    my $timeout_enabled = $prop->{timeout_enabled};
    my $write_timeout   = $prop->{write_timeout};

    my $len = length $_[1];
    my $offset = 0;
    while ($len) {
        if ( $len && $timeout_enabled && $write_timeout && ! _can_read_write($fh, $fd, $write_timeout, 1)) {
            $! ||= ETIMEDOUT;
            return -1;
        }
        my $r = syswrite($fh, $_[1], $len, $offset);
        if (defined $r) {
            $len -= $r;
            $offset += $r;
            last unless $len;
        }
        elsif ($! != EINTR) {
            return -1;
        }
    }
    return $offset;
}

sub _can_read_write {
    my ($fh, $fd, $timeout, $type) = @_;
    # $type: 0 = read, 1 = write
    my $initial = time;
    my $pending = $timeout;
    my $nfound;

    vec(my $fdset = '', $fd, 1) = 1;

    while () {
        if ($type) {
            # write
            $nfound = select(undef, $fdset, undef, $pending);
        } else {
            # read
            $nfound = select($fdset, undef, undef, $pending);
        }
        if ($nfound == -1) {
            $! == EINTR
              or croak(qq/select(2): '$!'/);
            redo if !$timeout || ($pending = $timeout - (time -
            $initial)) > 0;
            $nfound = 0;
        }
        last;
    }
    $! = 0;
    return $nfound;
}


sub read_timeout {
    my $prop = __PACKAGE__->_fh2prop($_[0]);
    @_ > 1 and $prop->{read_timeout} = $_[1] || 0, _check_attributes($prop);
    $prop->{read_timeout};
}


sub write_timeout {
    my $prop = __PACKAGE__->_fh2prop($_[0]);
    @_ > 1 and $prop->{write_timeout} = $_[1] || 0, _check_attributes($prop);
    $prop->{write_timeout};
}


sub _check_attributes {
    grep { $_[0]->{$_} < 0 } qw(read_timeout write_timeout)
      and croak "if defined, 'read_timeout' and 'write_timeout' attributes should be >= 0";
}


sub enable_timeout { timeout_enabled($_[0], 1) }


sub disable_timeout { timeout_enabled($_[0], 0) }


sub timeout_enabled {
    my $prop = __PACKAGE__->_fh2prop($_[0]);
    @_ > 1 and $prop->{timeout_enabled} = !!$_[1];
    $prop->{timeout_enabled};
}

1;

__END__