Current File : //data/old/usr/share/perl5/vendor_perl/PerlIO/via/Timeout.pm
#
# 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__
=pod
=head1 NAME
PerlIO::via::Timeout - a PerlIO layer that adds read & write timeout to a handle
=head1 VERSION
version 0.29
=head1 SYNOPSIS
use Errno qw(ETIMEDOUT);
use PerlIO::via::Timeout qw(:all);
open my $fh, '<:via(Timeout)', 'foo.html';
# set the timeout layer to be 0.5 second read timeout
read_timeout($fh, 0.5);
my $line = <$fh>;
if ($line == undef && 0+$! == ETIMEDOUT) {
# timed out
...
}
=head1 DESCRIPTION
This package implements a PerlIO layer, that adds read / write timeout. This
can be useful to avoid blocking while accessing a handle (file, socket, ...),
and fail after some time.
The timeout is implemented by using C<<select>> on the handle before
reading/writing.
B<WARNING> the handle won't timeout if you use C<sysread> or C<syswrite> on it,
because these functions works at a lower level. Hower if you're trying to
implement a timeout for a socket, see L<IO::Socket::Timeout> that implements
exactly that.
=head1 FUNCTIONS
=head2 read_timeout
# set a read timeout of 2.5 seconds
read_timeout($fh, 2.5);
# get the current read timeout
my $secs = read_timeout($fh);
Getter / setter of the read timeout value.
=head2 write_timeout
# set a write timeout of 2.5 seconds
timeout_layer($fh)->write_timeout(2.5);
# get the current write timeout
my $secs = timeout_layer($fh)->write_timeout();
Getter / setter of the write timeout value.
=head2 enable_timeout
enable_timeout($fh);
Equivalent to setting timeout_enabled to 1
=head2 disable_timeout
timeout_layer($fh)->disable_timeout();
Equivalent to setting timeout_enabled to 0
=head2 timeout_enabled
# disable timeout
timeout_enabled($fh, 0);
# enable timeout
timeout_enabled($fh, 1);
# get the current status
my $is_enabled = timeout_enabled($fh);
Getter / setter of the timeout enabled flag.
=head1 SEE ALSO
=over
=item L<PerlIO::via>
=back
=head1 THANKS TO
=over
=item Vincent Pit
=item Christian Hansen
=item Leon Timmmermans
=back
=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
Mini Shell