view release on metacpan or  search on metacpan

t/37-connection-state.t  view on Meta::CPAN

    my $c2 = PAGI::Server::ConnectionState->new();
    my $comp = 0;
    $c2->on_complete(sub { $comp = 1 });
    $c2->_mark_disconnected('write_error');
    $c2->_mark_complete;                          # must be ignored
    ok(!$comp, 'on_complete not fired after abnormal disconnect');
    is($c2->disconnect_reason, 'write_error', 'disconnect reason preserved');
};

subtest 'on_disconnect after completion does not fire' => sub {
    my $conn = PAGI::Server::ConnectionState->new();
    $conn->_mark_complete;

    my $called = 0;
    $conn->on_disconnect(sub { $called = 1 });

    ok(!$called, 'on_disconnect registered after clean completion never fires');
};

subtest 'on_complete callback errors do not break others' => sub {
    my $conn = PAGI::Server::ConnectionState->new();
    my $cb2_called = 0;

    $conn->on_complete(sub { die "error in cb1" });
    $conn->on_complete(sub { $cb2_called = 1 });

    my @warnings;
    local $SIG{__WARN__} = sub { push @warnings, @_ };

    $conn->_mark_complete;

    ok($cb2_called, 'cb2 still called despite cb1 error');
    like($warnings[0], qr/callback error/, 'warning emitted');
};

# =============================================================================
# Test: _handle_disconnect marks connection state BEFORE resuming parked
# drain waiters. A producer parked on a blocking backpressure await
# (_wait_for_drain) can be resumed synchronously the moment its Future is
# resolved (Future::AsyncAwait resumes inline off ->done, same as ->on_ready
# below); if that resumption races ahead of the connection-state marking, the
# app observes is_connected() == 1 immediately after its own disconnect was
# detected. Exercises the real Connection._handle_disconnect ordering
# directly (unit-level, no live socket needed).
# =============================================================================

subtest 'disconnect marks connection state before resuming parked drain waiters' => sub {
    my $conn = PAGI::Server::Connection->new(app => sub { });
    my $conn_state = PAGI::Server::ConnectionState->new(connection => $conn);
    $conn->{current_connection_state} = $conn_state;

    # A producer parked on a blocking backpressure await -- pushed directly
    # onto _drain_waiters (the same queue _wait_for_drain uses), without
    # needing a real stream/buffer to get there.
    my $parked = Future->new;
    push @{$conn->{_drain_waiters}}, $parked;

    my ($observed_connected, $observed_reason);
    $parked->on_ready(sub {
        # Fires synchronously from within _handle_disconnect below, exactly
        # as an awaiting coroutine resumes -- this is the resumed app's very
        # first chance to look at its own connection state.
        $observed_connected = $conn_state->is_connected;
        $observed_reason    = $conn_state->disconnect_reason;
    });

    $conn->_handle_disconnect('client_closed');

    is($observed_connected, 0,
        'resumed waiter observes is_connected already false (no stale-true window)');
    is($observed_reason, 'client_closed',
        'resumed waiter observes disconnect_reason already set');
};

# =============================================================================
# Test: response_complete accessor (SHOULD-level; unsupported -> undef)
# =============================================================================

subtest 'response_complete is undef (unsupported)' => sub {
    my $conn = PAGI::Server::ConnectionState->new();

    ok($conn->can('response_complete'), 'response_complete method exists');

    my $result = eval { $conn->response_complete };
    ok(!$@, 'response_complete does not throw') or diag("error: $@");
    is($result, undef, 'response_complete returns undef (unsupported)');
};

# =============================================================================
# Test: Server implements disconnect reason code paths (source inspection)
# =============================================================================

subtest 'server implements disconnect reason code paths' => sub {
    # Read the Connection.pm source
    my $source = do {
        open my $fh, '<', 'lib/PAGI/Server/Connection.pm' or die "Cannot read: $!";
        local $/;
        <$fh>;
    };

    # Verify protocol_error is set on parse failures
    like(
        $source,
        qr/_handle_disconnect\('protocol_error'\)/,
        'protocol_error reason used for parse failures'
    );

    # Verify server_shutdown auto-detection exists
    like(
        $source,
        qr/server_shutdown/,
        'server_shutdown reason is referenced'
    );

    like(
        $source,
        qr/\$self->\{server\}\{shutting_down\}/,
        'server shutdown state is checked'
    );
};