Returning SIGALRM can prematurely exhaust a fractional read timeout in can_read

Start by reading Net/HTTP/Methods.pm, especially can_read and its interrupted-select timeout calculation around the reported line 249; compare the wall-clock budget update with the fractional timeout and the reproducer’s SIGALRM behavior. Run the standalone repro.pl with the saved fixture to confirm the failure, then verify the fix preserves complete responses under periodic alarms and keeps the no-alarm control passing.

A complete local HTTP response is truncated by Net::HTTP::Methods::can_read when a returning periodic SIGALRM crosses a wall-clock second. This reproduces without an application client or any installed package changes.

Observed with Perl 5.38.2, LWP 6.67, Net::HTTP 6.22. The installed Net/HTTP/Methods.pm SHA-256 is ad4aca179123acaea40630b9cd449809b01e8be27bd5c5ed3aaf26663e03390a.

The reproducer starts its own loopback server, serves the same complete saved 695-byte JSON response in eight pieces with 0.1 seconds between pieces, and configures LWP::UserAgent->new(timeout => 0.3). A returning SIGALRM repeats every 0.08 seconds. The minimal handler preserves $! and increments a counter. All child process groups are terminated and reaped.

Each inter-packet gap is below the 0.3-second inactivity timeout. The no-alarm control receives all 695 bytes in about 0.73 seconds. All four periodic-alarm samples instead return HTTP 200 with an incomplete body, no thrown exception, Client-Aborted: die, and:

read timeout at .../Net/HTTP/Methods.pm line 249.

All four partial bodies fail JSON decoding. The control is byte-for-byte equal to the original full response and is valid JSON. The installed source hashes were unchanged before and after the run.

The likely mechanism is the existing interrupted-select budget calculation in can_read:

$before = time if $timeout;
my $nfound = select($fbits, undef, undef, $timeout);
if ($nfound < 0) {
    if ($!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK}) {
        if ($timeout) {
            $timeout -= time - $before;
            $timeout = 0 if $timeout < 0;
        }
        redo SELECT;
    }
    die "select failed: $!";
}

time here is core integer wall time. An interruption across a second can subtract 1 from a fractional 0.3-second budget after much less than 0.3 seconds. my_read then throws read timeout. LWP's collect catches this, adds X-Died/Client-Aborted, and preserves the original HTTP 200 and partial content. The measured start phases and failures after the second/third alarm are consistent with that path. No replacement clock or package patch was applied in this reproduction.

The same core-time subtraction is present in upstream tag v6.19 and in the currently inspected default-branch source declaring 6.25. Those versions were source-inspected, not standalone-runtime-tested here. Separate application diagnostics on Perl 5.26.2/LWP 6.49/Net::HTTP 6.19 retained two early invalid-JSON outcomes in 20 samples at about 79.8 and 160.1 ms, but did not capture those native response headers, so that observation alone is not being used as a transport attribution.

I searched all-state issues for EINTR, alarm, fractional, timeout and time. Related issues #27 (general/chunked read timeout), #28 (SSL read retry/errno), #33 (connection latency) and #95 (nonblocking my_readline) describe different paths; I did not find an exact duplicate in that bounded search.

To reproduce, save the complete real fixture below as fixture.json, then save the standalone program as repro.pl and run:

perl repro.pl fixture.json report.json

The report path must not already exist. It records every sample, full-body and returned-body hashes, response headers, versions, source hashes and child cleanup. Only localhost is contacted; there are no credentials or business/database operations.

Complete minimized fixture, preserving the original request and entire captured response:

{
  "requests": {
    "pack": {
      "items": [
        {
          "name": "Mini Card",
          "x": 1.75,
          "y": 2.5,
          "z": 0.015,
          "weight": 0.0045,
          "quantity": 1
        }
      ],
      "box_types": [
        {
          "name": "poker tuck box 54",
          "x": 2.5,
          "y": 3.5,
          "z": 0.81,
          "weight": 0.256
        }
      ]
    }
  },
  "responses": {
    "pack": {
      "packing_list": [
        {
          "id": "8c7fa280-7e15-435f-85db-7c9edf3469d2",
          "name": "poker tuck box 54",
          "weight": 0.2605,
          "packing_list": {
            "Mini Card": 1
          }
        }
      ],
      "packing_instructions": [
        {
          "x": 2.5,
          "y": 3.5,
          "z": 0.81,
          "fill_x": "2.5000",
          "fill_y": "1.7500",
          "fill_z": "0.0150",
          "name": "poker tuck box 54",
          "id": "8c7fa280-7e15-435f-85db-7c9edf3469d2",
          "weight": 0.256,
          "calculated_weight": 0.43970000000000004,
          "used_volume": 0.065625,
          "fill_volume": 0.065625,
          "volume": 7.0875,
          "layers": [
            {
              "rows": [
                {
                  "items": [
                    {
                      "name": "Mini Card",
                      "weight": 0.0045,
                      "x": 2.5,
                      "y": 1.75,
                      "z": 0.015
                    }
                  ],
                  "fill_x": 2.5,
                  "fill_y": 1.75,
                  "fill_z": 0.015,
                  "calculated_weight": 0.0045
                }
              ],
              "fill_x": "2.5000",
              "fill_y": "1.7500",
              "fill_z": "0.0150",
              "calculated_weight": 0.0045
            }
          ]
        }
      ],
      "box_count": 1,
      "warnings": []
    }
  }
}

Standalone reproduction:

use strict;
use warnings;
use IO::Socket::INET;
use IO::Select;
use LWP::UserAgent;
use LWP::Protocol::http;
use Net::HTTP::Methods;
use JSON::XS qw(decode_json encode_json);
use Digest::SHA qw(sha256_hex);
use Fcntl qw(O_WRONLY O_CREAT O_EXCL);
use POSIX qw(_exit setpgid WNOHANG floor);
use Time::HiRes qw(time sleep clock_gettime CLOCK_MONOTONIC setitimer ITIMER_REAL);

# Pure transport reproduction: supply the unchanged complete packing fixture.
# No Wing, database, Box::Calc client, public endpoint or installed code edits.
my ($fixture_path, $output_path) = @ARGV;
die "Usage: perl $0 COMPLETE_FIXTURE.json EXCLUSIVE_REPORT.json\n" unless @ARGV == 2;
sub bytes {
    my ($path) = @_;
    open my $fh, '<:raw', $path or die "Read source/fixture: $!";
    local $/;
    my $bytes = <$fh>;
    close $fh or die "Close source/fixture: $!";
    return $bytes;
}
my $fixture_bytes = bytes($fixture_path);
my $fixture = decode_json($fixture_bytes);
my $body = encode_json($fixture->{responses}{pack});
my $request_body = encode_json($fixture->{requests}{pack});
die "Complete real pack request/response required\n"
    unless ref($fixture->{requests}{pack}) eq 'HASH'
        && ref($fixture->{responses}{pack}) eq 'HASH';
my %sources = map { $_ => {path => $INC{$_}, sha256 => sha256_hex(bytes($INC{$_}))} }
    qw(LWP/UserAgent.pm LWP/Protocol.pm LWP/Protocol/http.pm Net/HTTP.pm Net/HTTP/Methods.pm);
my %children;
sub cleanup {
    my ($pid) = @_;
    return unless delete $children{$pid};
    my $state = waitpid($pid, WNOHANG);
    return if $state == $pid || $state == -1;
    kill 'TERM', -$pid;
    kill 'TERM', $pid;
    my $end = clock_gettime(CLOCK_MONOTONIC) + 1;
    while (clock_gettime(CLOCK_MONOTONIC) < $end) {
        $state = waitpid($pid, WNOHANG);
        return if $state == $pid || $state == -1;
        sleep 0.01;
    }
    kill 'KILL', -$pid;
    kill 'KILL', $pid;
    waitpid($pid, 0);
}
END { setitimer(ITIMER_REAL, 0); cleanup($_) for keys %children; }
sub write_all {
    my ($socket, $bytes) = @_;
    while (length $bytes) {
        my $n = syswrite($socket, $bytes);
        die "Write local response: $!" unless defined $n && $n > 0;
        substr($bytes, 0, $n, '');
    }
}
sub server {
    my $listener = IO::Socket::INET->new(LocalAddr => '127.0.0.1',
        LocalPort => 0, Listen => 1, ReuseAddr => 1, Proto => 'tcp')
        or die "Create owned localhost listener: $!";
    my $port = $listener->sockport;
    pipe(my $ready_read, my $ready_write) or die "Create readiness pipe: $!";
    my $pid = fork;
    die "Fork owned localhost server: $!" unless defined $pid;
    if (!$pid) {
        close $ready_read;
        my $ok = eval {
            setpgid(0, 0) == 0 or die "Set owned process group: $!";
            $SIG{PIPE} = 'IGNORE';
            syswrite($ready_write, '1') == 1 or die "Announce server readiness: $!";
            close $ready_write;
            IO::Select->new($listener)->can_read(2) or die "Local accept exceeded 2 seconds";
            my $socket = $listener->accept or die "Accept local request: $!";
            close $listener;
            my $incoming = '';
            until ($incoming =~ /\r\n\r\n/) {
                my $n = sysread($socket, my $part, 4096);
                die "Read local headers: $!" unless defined $n && $n > 0;
                $incoming .= $part;
            }
            my ($headers, $received) = split /\r\n\r\n/, $incoming, 2;
            my ($length) = $headers =~ /^Content-Length:\s*(\d+)/mi;
            die "Missing request content length" unless defined $length;
            while (length($received) < $length) {
                my $n = sysread($socket, my $part, 4096);
                die "Read local body: $!" unless defined $n && $n > 0;
                $received .= $part;
            }
            decode_json($received);
            write_all($socket, "HTTP/1.1 200 Local response\r\nContent-Type: application/json\r\n"
                .'Content-Length: '.length($body)."\r\nConnection: close\r\n\r\n");
            my $remaining = $body;
            my $chunk_size = int((length($body) + 7) / 8);
            my $first = 1;
            while (length $remaining) {
                sleep 0.1 unless $first;
                $first = 0;
                write_all($socket, substr($remaining, 0, $chunk_size, ''));
            }
            close $socket;
            1;
        };
        _exit($ok ? 0 : 1);
    }
    close $ready_write;
    close $listener;
    $children{$pid} = 1;
    my $announced;
    my $n = IO::Select->new($ready_read)->can_read(2)
        ? sysread($ready_read, $announced, 1) : undef;
    close $ready_read;
    die "Local server readiness failed" unless defined $n && $n == 1 && $announced eq '1';
    return ($pid, $port);
}
my @samples;
for my $profile (
    ['no-alarm-control', 0.84, 0],
    ['returning-periodic-1', 0.84, 0.08],
    ['returning-periodic-2', 0.84, 0.08],
    ['returning-periodic-3', 0.84, 0.08],
    ['returning-periodic-4', 0.75, 0.08],
) {
    my ($label, $phase, $period) = @$profile;
    my ($pid, $port) = server();
    my $now = time;
    my $target = floor($now) + $phase;
    $target++ if $target <= $now;
    sleep($target - $now);
    my $callbacks = 0;
    # Preserve errno to exclude handler-side errno changes as the cause.
    local $SIG{ALRM} = sub { local $!; ++$callbacks; };
    my $ua = LWP::UserAgent->new(timeout => 0.3);
    my $started_wall = time;
    my $started = clock_gettime(CLOCK_MONOTONIC);
    setitimer(ITIMER_REAL, $period, $period) if $period;
    my ($response, $error);
    { local $@; $response = eval {
        $ua->post("http://127.0.0.1:$port/api/pack",
            Content_Type => 'application/json', Content => $request_body);
    }; $error = "$@"; }
    my $elapsed_ms = (clock_gettime(CLOCK_MONOTONIC) - $started) * 1000;
    setitimer(ITIMER_REAL, 0);
    my $content = $response ? $response->content : '';
    my $valid_json = eval { decode_json($content); 1 } ? 1 : 0;
    push @samples, {
        label => $label, wallStart => $started_wall,
        wallFraction => $started_wall - floor($started_wall),
        inactivityTimeoutSeconds => 0.3, returningAlarmPeriodSeconds => $period,
        callbackCount => $callbacks, elapsedMilliseconds => $elapsed_ms,
        status => $response ? $response->code : undef,
        declaredContentLength => $response ? scalar($response->header('Content-Length')) : undef,
        returnedBodyBytes => length($content), returnedBodySha256 => sha256_hex($content),
        completeBody => ($content eq $body ? JSON::XS::true : JSON::XS::false),
        validJson => ($valid_json ? JSON::XS::true : JSON::XS::false),
        xDied => $response ? scalar($response->header('X-Died')) : undef,
        clientAborted => $response ? scalar($response->header('Client-Aborted')) : undef,
        thrownException => $error,
    };
    cleanup($pid);
}
my $report = {
    schemaVersion => 1, versions => {perl => "$^V", LWP => $LWP::UserAgent::VERSION,
        NetHTTP => $Net::HTTP::VERSION, NetHTTPMethods => $Net::HTTP::Methods::VERSION},
    reproductionSha256 => sha256_hex(bytes($0)),
    fixture => {path => $fixture_path, sha256 => sha256_hex($fixture_bytes),
        completeBodyBytes => length($body), completeBodySha256 => sha256_hex($body)},
    transportSources => \%sources, samples => \@samples,
    installedSourcesUnchanged => (scalar(grep { sha256_hex(bytes($sources{$_}{path}))
        ne $sources{$_}{sha256} } keys %sources) ? JSON::XS::false : JSON::XS::true),
    ownedChildrenReaped => (keys(%children) ? JSON::XS::false : JSON::XS::true),
    businessIo => {databaseCalls => 0, applicationClientCalls => 0, remoteRequests => 0},
};
sysopen(my $out, $output_path, O_WRONLY | O_CREAT | O_EXCL, 0600)
    or die "Create exclusive private report: $!";
print {$out} JSON::XS->new->canonical->pretty->encode($report) or die "Write report: $!";
close $out or die "Close report: $!";
print JSON::XS->new->canonical->encode({report => $output_path,
    samples => scalar(@samples), partialSamples => scalar(grep {!$_->{completeBody}} @samples),
    ownedChildrenReaped => $report->{ownedChildrenReaped}}), "\n";