File Coverage

blib/lib/IO/SigGuard.pm

Criterion	Covered	Total	%
statement	33	34	97.0
branch	11	18	61.1
condition	2	5	40.0
subroutine	7	7	100.0
pod	1	3	33.3
total	54	67	80.6

package IO::SigGuard;

=encoding utf-8

=head1 NAME

IO::SigGuard - Signal protection for sysread/syswrite

=head1 SYNOPSIS

    IO::SigGuard::sysread( $fh, $buf, $size );
    IO::SigGuard::sysread( $fh, $buf, $size, $offset );

    IO::SigGuard::syswrite( $fh, $buf );
    IO::SigGuard::syswrite( $fh, $buf, $len );
    IO::SigGuard::syswrite( $fh, $buf, $len, $offset );

    IO::SigGuard::select( $read, $write, $exc, $timeout );

=head1 DESCRIPTION

C describes how Perl versions from 5.8.0 onward disable
the OS’s SA_RESTART flag when installing Perl signal handlers.

This module restores that pattern: it does an automatic restart
when a signal interrupts an operation, so you can entirely avoid
the generally-useless EINTR error when using
C, C, and C.

=head1 ABOUT C and C

Other than that you’ll never see EINTR and that
there are no function prototypes used (i.e., you need parentheses on
all invocations), C and C
work exactly the same as Perl’s equivalent built-ins.

=head1 ABOUT C

To handle EINTR, C has to subtract the elapsed time
from the given timeout then repeat the internal C. Because
the C built-in’s C<$timeleft> return is not reliable across
all platforms, we have to compute the elapsed time ourselves. By default the
only means of doing this is the C built-in, which can only measure
individual seconds.

This works, but there are two ways to make it more accurate:

=over

=item * Have L loaded, and C will use that
module rather than the C built-in.

=item * Set C<$IO::SigGuard::TIME_CR> to a compatible code reference. This is
useful, e.g., if you have your own logic to do the equivalent of
L—for example, in Linux you may prefer to call the C
system call directly from Perl to avoid L’s XS overhead.

=back

In scalar contact, C is a drop-in replacement
for Perl’s 4-argument built-in.

In list context, there may be discrepancies re the C<$timeleft> value
that Perl returns from a call to C. As per Perl’s documentation
this value is generally not reliable anyway, though, so that shouldn’t be a
big deal. In fact, on systems (e.g., MacOS) where the built-in’s C<$timeleft>
is completely useless, IO::SigGuard’s return is actually B since it
does provide at least a rough estimate of how much of the given timeout value
is left.

See C for portability notes for C.

=cut

use strict;
use warnings;

our $VERSION = '0.02-TRIAL6';

#Set this in lieu of using Time::HiRes or built-in time().
our $TIME_CR;

#As light as possible …

my $read;

sub sysread {
  READ: {
        $read = ( (@_ == 3) ? CORE::sysread( $_[0], $_[1], $_[2] ) : (@_ == 4) ? CORE::sysread( $_[0], $_[1], $_[2], $_[3] ) : die "Wrong args count! (@_)" ) or do {
            if ($!) {
                redo READ if $!{'EINTR'};
            }
        };
    }

    return $read;
}

my $wrote;

sub syswrite {
    $wrote = 0;

  WRITE: {
        $wrote += ( (@_ == 2) ? CORE::syswrite( $_[0], $_[1], length($_[1]) - $wrote, $wrote ) : (@_ == 3) ? CORE::syswrite( $_[0], $_[1], $_[2] - $wrote, $wrote ) : (@_ == 4) ? CORE::syswrite( $_[0], $_[1], $_[2] - $wrote, $_[3] + $wrote ) : die "Wrong args count! (@_)" ) || do {
            if ($!) {
                redo WRITE if $!{'EINTR'};  #EINTR => file pointer unchanged
                return undef;
            }

            die "empty write without error??";  #unexpected!
        };
    }

    return $wrote;
}

my ($start, $last_loop_time, $os_error, $nfound, $timeleft, $timer_cr);

#pre-5.16 didn’t have \&CORE::time.
sub _time { time }

sub select {
    die( (caller 0)[3] . ' must have 4 arguments!' ) if @_ != 4;

    $os_error = $!;

    $timer_cr = $TIME_CR || Time::HiRes->can('time') || \&_time;

    $start = $timer_cr->();
    $last_loop_time = $start;

  SELECT: {
        ($nfound, $timeleft) = CORE::select( $_[0], $_[1], $_[2], $_[3] - $last_loop_time + $start );
        if ($nfound == -1) {

            #Use of %! will autoload Errno.pm,
            #which can affect the value of $!.
            my $select_error = $!;

            if ($!{'EINTR'}) {
                $last_loop_time = $timer_cr->();
                redo SELECT;
            }

            $! = $select_error;
        }
        else {

            #select() doesn’t set $! on success, so let’s not clobber what
            #value was there before.
            $! = $os_error;
        }

        return wantarray ? ($nfound, $timeleft) : $nfound;
    }
}

=head1 REPOSITORY

L

=head1 AUTHOR

Felipe Gasper (FELIPE)

… with special thanks to Mario Roy (MARIOROY) for extra testing
and a few fixes/improvements.

=head1 COPYRIGHT

Copyright 2017 by L

=head1 LICENSE

This distribution is released under the same license as Perl.

=cut

1;