Using Perl's readline , <> function with TCP socket and Signals

I'm using Perl 5.8.8 and trying to determine if Perl automatically and consistently restarts the readline function ( better known as <> ) if it's interrupted by a signal.

I want to safely read newline '\n' terminated strings from a TCP socket using readline.

In the section Deferred Signals (Safe Signals) it says:

Restartable system calls

On systems that supported it, older versions of Perl used the SA_RESTART flag when installing %SIG handlers. This meant that restartable system calls would continue rather than returning when a signal arrived. In order to deliver deferred signals promptly, Perl 5.7.3 and later do not use SA_RESTART. Consequently, restartable system calls can fail (with $! set to EINTR ) in places where they previously would have succeeded.

Note that the default :per开发者_如何学JAVAlio layer will retry read, write and close as described above and that interrupted wait and waitpid calls will always be retried.

Now it also says elsewhere that readline is implemented in terms of read.

I'm thinking that if I do the following it should do what I want as I assume readline either returns a full line or undef:

sub Readline {
    my $sockfd = shift;

    my $line;

    while (!defined($line = readline($sockfd))) {
        next if $!{EINTR};
        last if eof($sockfd); # socket was closed
        die "readline: $!";
    }
    return $line;
}

Will this do what I want?

It appears to be overkill based on this simple test (at least for Linux):

#! /usr/bin/perl

use warnings;
use strict;

my $interrupt = 0;
sub sigint {
  ++$interrupt;
}

$SIG{INT} = \&sigint;

my $line = <STDIN>;

print "interrupt = $interrupt\n",
      "line = $line";

Running it:

$ ./prog.pl
foo^Cbar
interrupt = 1
line = bar

Where you see ^C in the typescript, I pressed Ctrl-C.

Interrupting a socket read is a little trickier, so go all out:

#! /usr/bin/perl

use warnings;
use strict;

use IO::Select;
use IO::Socket;
use IPC::SysV qw/ IPC_PRIVATE S_IRUSR S_IWUSR IPC_CREAT /;
use IPC::Semaphore;
use Time::HiRes qw/ usleep /;

# Keep $SEND_INTERVAL larger than $KILL_INTERVAL to
# allow many signals to be sent.
my $PORT = 55555;
my $INTERFACE = "eth0";
my $DEFAULT_MTU = 1500;
my $KILL_INTERVAL = 0; # microseconds
my $SEND_INTERVAL = 200_000; # microseconds
my $NUM_READLINES = 100;

sub addr_mtu {
  my($interface) = @_;

  my($addr,$mtu);
  if (open my $ifcfg, "-|", "ifconfig $interface") {
    while (<$ifcfg>) {
      $addr = $1 if /inet\s+addr\s*:\s*(\S+)/;
      $mtu  = $1 if /MTU\s*:\s*(\d+)/;
    }
  }

  die "$0: no address" unless defined $addr;
  unless (defined $mtu) {
    $mtu = $DEFAULT_MTU;
    warn "$0: defaulting MTU to $mtu";
  }

  ($addr,$mtu);
}

sub build_packet {
  my($len) = @_;

  my $seed = join "" => 0 .. 9, 'A' .. 'Z', 'a' .. 'z';
  my $packet = "";
  $packet .= $seed while length($packet) < $len;

  substr($packet, 0, $len-2) . "\r\n";
}

sub take {
  my($sem) = @_;
  while (1) {
    $sem->op(
      0, 0, 0,
      0, 1, 0,
    );
    return unless $!;
    next if $!{EINTR};
    die "$0: semop: $!";
  }
}

sub give {
  my($sem) = @_;
  while (1) {
    $sem->op(0, -1, 0);
    return unless $!;
    next if $!{EINTR};
    die "$0: semop: $!";
  }
}

my($addr,$mtu) = addr_mtu $INTERFACE;
my $pkt = build_packet $mtu;

my $lsn = IO::Socket::INET->new(Listen => 1, LocalAddr => "$addr:$PORT", ReuseAddr => 1);
die "$0: create listen socket: $!" unless defined $lsn;

my $interrupt = 0;
sub sigint {
  ++$interrupt;
}
$SIG{INT} = \&sigint;

my $sem = IPC::Semaphore->new(IPC_PRIVATE, 1, S_IRUSR|S_IWUSR|IPC_CREAT);
die unless defined $sem;
$sem->setall(1);

my $parent = $$;
my $pid = fork;
die "$0: fork: $!" unless defined $pid;
if ($pid == 0) {
  warn "$0: [$$] killer\n";
  my $sent;
  while (1) {
    my $n = kill INT => $parent;
    ++$sent;
    unless ($n > 0) {
      warn "$0: kill INT $parent: $!" if $!;
      warn "$0: [$$] killer exiting; sent=$sent\n";
      exit 0;
    }

    # try to stay under 120 pending-signal max
    if ($sent % 100 == 0) {
      usleep $KILL_INTERVAL;
    }
  }
}

$pid = fork;
die "$0: fork: $!" unless defined $pid;
if ($pid == 0) {
  warn "$0: [$$] sender\n";
  my $s = IO::Socket::INET->new(PeerAddr => "$addr:$PORT");
  unless (defined $s) {
    warn "$0: failed to connect to $addr:$PORT";
    kill TERM => $parent;
    exit 1;
  }

  warn "$0: [$$]: connected to parent\n";
  give $sem;

  my $n;
  while (1) {
    my $bytes = $s->send($pkt, 0);
    warn("$0: send: $!"), last unless defined $bytes;
    warn("$0: short send ($bytes vs. $mtu)"), last unless $bytes == $mtu;
    ++$n;
    warn "$0: [$$] sent $n" if $n % 50 == 0;
    usleep $SEND_INTERVAL;
  }

  $s->close;
  warn "$0: [$$]: sender exiting\n";
  exit 1;
}

take $sem;
my $fh = $lsn->accept;
$lsn->close;
$/ = "\r\n";
for (my $n = 1; $n <= $NUM_READLINES; ++$n) {
  warn "$0: [$$] n=$n; interrupt=$interrupt\n";
  my $line = <$fh>;
  my $len = length $line;
  warn "$0: FAILED: mtu=$mtu; got $len\n" unless $len == $mtu;
}
$fh->close;

warn "$0: parent exiting; interrupt=$interrupt\n";
exit 0;

This produced no short reads on my Linux host. The end of its output:

./server: [28633] n=97; interrupt=104665
./server: [28633] n=98; interrupt=105936
./server: [28633] n=99; interrupt=107208
./server: [28633] n=100; interrupt=108480
./server: [28637] sent 100 at ./server line 132.
./server: parent exiting; interrupt=109751
./server: kill INT 28633: No such process at ./server line 100.
./server: [28636] killer exiting; sent=11062802

If I really cranked up the signal rate, I'd get a warning of

Maximal count of pending signals (120) exceeded.

both on the line with <$fh> and during global destruction, but there's nothing you'd be able to do about that in your program.

The doc you quoted contains:

Note that the default :perlio layer will retry read, write and close as described above and that interrupted wait and waitpid calls will always be retried.

The behavior of the above two test programs show it highly likely that this is what's going on, i.e., the read inside readline is restarting properly when interrupted.

I also think this is overkill -- I can't get readline to be interrupted (under Cygwin, Linux, Perl v5.8 and v5.10)¹. I think the perlio layer is taking care of this, as your link documents.

¹ The test procedure is to: (1) install a signal handler (in my case a SIGCHLD handler), (2) schedule the process to receive signals (in my case, call fork() hundreds of times, with the child processes sleeping for a short but random time), (3) call the Perl function of interest while signals are arriving and interrupting the main execution thread (4) observe whether the call completed normally or whether it set $! and $!{EINTR}.

It is easy to show that a sleep call can be interrupted like this. If you are patient you can also see that you can interrupt a connect call. The conclusion of these tests is that you cannot interrupt a readline call, even on an I/O starved socket. I do see that the signals are handled (that is, the system is not deferring the signals, waiting for readline to complete before delivering them). Hope this helps.