view release on metacpan or  search on metacpan

lib/IPC/Manager/Test.pm  view on Meta::CPAN

    # gone, and await_response would croak with "peer ... went away"
    # instead of returning the response that had already been delivered.
    #
    # Reproduce the race deterministically: send the request via the
    # async API, sleep long enough for the service to respond and fully
    # tear down (so its registration is gone from the bus), then call
    # await_response.  The response is sitting in the parent's inbox;
    # peer_active reports gone.  Without the in-transit drain in
    # await_response, this throws "peer ... went away".
    my $iters = 5;
    my @errors;

    for my $i (1 .. $iters) {
        my $done = 0;
        my $name = "exit_after_resp_$i";

        my $handle = ipcm_service(
            $name,
            class          => 'IPC::Manager::Service',
            handle_request => sub {
                my ($self, $req, $msg) = @_;
                $done = 1;
                return {ok => 1, n => $req->{request}->{n}};
            },
            should_end => sub { $done },
        );

        my $req_id = $handle->send_request($name, {n => $i});

        # Wait for the service process to die and the bus to deregister it.
        # waitpid the child the spawn started, so peer_active() definitively
        # reports gone by the time await_response runs.  Prefer blocking
        # waitpid for direct children; fall back to a short poll otherwise.
        my $svc_pid = $handle->child_pid;
        if (defined $svc_pid) {
            my $r = waitpid($svc_pid, 0);
            if ($r == -1) {
                for (1 .. 50) {
                    last unless pid_is_running($svc_pid);
                    Time::HiRes::sleep(0.05);
                }
            }
        }
        else {
            Time::HiRes::sleep(1);
        }

        my $resp;
        my $ok  = eval { $resp = $handle->await_response($req_id); 1 };
        my $err = $@;
        if (!$ok) {
            push @errors => "iter $i: $err";
        }
        elsif (!ref($resp) || ($resp->{response}{n} // -1) != $i) {
            push @errors => "iter $i: bad response: " . (ref($resp) ? $resp->{response}{n} // 'undef' : $resp);
        }

        $handle = undef;
    }

    is(\@errors, [], "no peer-gone exceptions across $iters exits-after-response iterations");
}

sub test_multiple_requests {
    my $handle = ipcm_service(
        'multi_svc',
        class          => 'IPC::Manager::Service',
        handle_request => sub {
            my ($self, $req, $msg) = @_;
            return "reply_$req->{request}";
        },
    );

    my @got;
    for my $i (1 .. 5) {
        $handle->send_request(
            multi_svc => "req_$i",
            sub {
                my ($resp, $msg) = @_;
                push @got, $resp->{response};
            },
        );
    }

    $handle->await_all_responses;

    is(scalar @got, 5, "Got all 5 responses");
    is([sort @got], [sort map { "reply_req_$_" } 1..5], "All responses correct");

    $handle = undef;
}

sub test_handle_messages_buffer {
    my $handle = ipcm_service(
        'buf_svc',
        class          => 'IPC::Manager::Service',
        handle_request => sub {
            my ($self, $req, $msg) = @_;

            # Send a non-response message back alongside the response
            $self->client->send_message(
                $msg->from,
                {notification => "event_$req->{request}"},
            );

            return "ack";
        },
    );

    my $resp = $handle->sync_request(buf_svc => "ping");
    is($resp->{response}, "ack", "Got response");

    # The notification should be in the handle's message buffer
    my @buffered = $handle->messages;
    is(scalar @buffered, 1, "One buffered non-response message");
    is($buffered[0]->content->{notification}, "event_ping", "Notification content correct");

    # Buffer is drained
    my @again = $handle->messages;
    is(scalar @again, 0, "Buffer empty after drain");