/ 
DBIO-0.900004
/ DBIO::Test::AsyncHarness

NAME

DBIO::Test::AsyncHarness - Parameterised live harness base for DBIO async transports

VERSION

version 0.900004

SYNOPSIS

use Test::More;
use DBIO::PostgreSQL::EV::TestHarness;

# Skip the whole file cleanly unless a live DSN + the transport are available.
DBIO::PostgreSQL::EV::TestHarness->skip_all_unless_live;

my $h = DBIO::PostgreSQL::EV::TestHarness->new(
    connect_attrs => {
        on_connect_do => [ q{SET myapp.replay_tag = 'live'} ],
        pool_size     => 4,
    },
);

# Force 3 DISTINCT pool connections to spawn (each replays the connect
# actions at spawn) and run an async op on each.
my @tags = $h->run_on_each_pooled_connection(3, sub {
    my ($conn, $harness) = @_;
    return $harness->query_on($conn, q{SELECT current_setting('myapp.replay_tag')});
});
is $_->[0][0], 'live', 'connect action replayed on this pooled connection'
    for @tags;

$h->disconnect;
done_testing;

DESCRIPTION

The harness every async transport's live test suite writes: parse the driver's DBIO_TEST_*_DSN, connect a schema with { async => $mode }, reach the embedded async backend and its pool, drive the event loop until a Future is ready, and force distinct pool connections to spawn so an on_connect replay can be asserted per connection.

None of that is driver-specific except four declarations and one seam, so it lives here once (ADR 0030 section 4) instead of being copied per transport dist. dbio-postgresql-ev and dbio-mysql-ev had grown two copies of it that differed only in an environment-variable prefix, two class names and one redundant extra step.

A transport dist subclasses this, declares what it is, and supplies the one thing core cannot know -- how to turn its event loop:

package DBIO::PostgreSQL::EV::TestHarness;
use base 'DBIO::Test::AsyncHarness';

__PACKAGE__->harness_env_prefix('DBIO_TEST_PG');
__PACKAGE__->harness_async_mode('ev');
__PACKAGE__->harness_required_modules([qw( EV EV::Pg )]);
__PACKAGE__->harness_schema_class('DBIO::PostgreSQL::EV::TestHarness::_Schema');

sub _tick_loop { EV::run(EV::RUN_ONCE()) }

ATTRIBUTES

harness_env_prefix

Class data. The environment-variable prefix this transport's DSN lives under, without a trailing underscore: DBIO_TEST_PG means DBIO_TEST_PG_DSN, DBIO_TEST_PG_USER and DBIO_TEST_PG_PASS. Required.

harness_async_mode

Class data. The async mode passed as { async => ... } on connect (ADR 0030): 'ev', 'future_io', 'forked', ... Required, and deliberately not defaulted -- which execution model a harness drives is the first thing its reader needs to know.

harness_required_modules

Class data. Arrayref of modules that must load for the transport to run, e.g. [qw( EV EV::Pg )]. Defaults to none, which is correct for a mode that needs no event loop.

harness_schema_class

Class data. The schema class "new" connects when the caller supplies no schema_class. Required.

harness_default_timeout

Class data. Wall-clock seconds "await" waits before failing loudly. Defaults to 30; a per-instance timeout option to "new" overrides it.

METHODS

env_var

my $name = $class->env_var('DSN');    # e.g. DBIO_TEST_PG_DSN

The full environment-variable name for $suffix under this harness's "harness_env_prefix".

live_available

Harness->live_available or ...;

Class method. True when this transport's ..._DSN is set and every module in "harness_required_modules" loads -- i.e. the live harness can run.

skip_all_unless_live

Harness->skip_all_unless_live;

Class method. When the live harness is unavailable (see "live_available"), calls Test::More::plan(skip_all => ...), which skips and exits the test file cleanly. A no-op when live testing is available.

new

my $h = Harness->new(%opts);

Connect a schema with this harness's async mode and make its embedded async backend reachable. Options:

  • dsn / user / pass -- connect info; default to the ..._DSN / ..._USER / ..._PASS variables under "harness_env_prefix".

  • schema_class -- the schema class to connect (default "harness_schema_class"). Supply your own to register storage layers or components -- this is how an extension injects its behaviour.

  • storage_type -- the driver's storage class, for a schema_class that declares no driver of its own (DBIO::Test::Schema):

    my $h = DBIO::PostgreSQL::EV::TestHarness->new(
    schema_class => 'DBIO::Test::Schema',
    storage_type => 'DBIO::PostgreSQL::Storage',
);

    The harness then connects a clone of the schema class declaring that driver, and the class itself stays undeclared -- as "init_schema" in DBIO::Test takes it (ADR 0067). Without it the schema class must declare its driver itself, or core refuses the connect. The harness keeps it as $h->{storage_type} for every further connection it makes on the same schema class ("parity_sync_schema" in DBIO::Test::AsyncParity).

  • connect_attrs -- extra connect attributes merged into the { async => $mode, ... } attrs hash, e.g. on_connect_do, on_connect_call, pool_size. These are exactly the actions replayed on each pooled connection.

  • timeout -- wall-clock seconds "await" waits before failing loudly (default "harness_default_timeout").

Croaks unless "live_available" -- call "skip_all_unless_live" first.

schema

The connected schema instance.

sync_storage

The sync storage the schema connected to -- the owner of the async backend. Forces driver determination on first call.

async

The embedded async backend, possibly with composed extension async layers. Built lazily on first access via the sync storage's async resolver, which also wires the owner back-reference.

pool

The async backend's connection pool (a DBIO::Storage::PoolBase).

timeout

Wall-clock seconds "await" waits: the timeout passed to "new", else "harness_default_timeout". It may be a fraction of a second. A false value is no timeout at all: "await" then sets no alarm, and waits for as long as it takes.

await

my @result = $h->await($future);

Drive the event loop until $future is ready, then return its result (dies on a failed Future). Guarded by a wall-clock alarm so a hang fails loudly instead of spinning forever: after "timeout" seconds it dies with TIMEOUT awaiting Future in $class.

An already-ready Future is returned without turning the loop at all, so a transport whose Futures resolve synchronously (immediate, forked) needs no "_tick_loop" to use this harness.

The alarm is borrowed. A process has one alarm, and a test file may have set it already to guard itself against a hang:

$SIG{ALRM} = sub { BAIL_OUT('a wait did not end') };
alarm 120;

await used to end with alarm 0, which cleared that alarm at the first await and left the rest of the file unguarded. Now an alarm that is running when await is entered is running when it is left, on every way out -- the Future ready, a die in "_tick_loop", the timeout:

  • It is due when it was due: it goes on with what it had left less the time spent in await, not from the start again.

  • When it is due before the timeout, it is the one that fires, at its time and under the handler it was set with -- await sets none of its own until then, so an alarm without a handler ends the process as it would have anywhere else. If its handler returns, the wait goes on and the timeout is still in force, counted from when await was entered.

  • When the timeout is due first, the outer alarm is off the clock while await waits. Should its time pass meanwhile -- a callback stayed in the loop past the timeout -- it fires as soon as await is left.

  • An await called from a callback inside another one's "_tick_loop" treats that one's timeout the same way, so neither takes the other's.

With no alarm running, none is running afterwards.

The bookkeeping is done with Time::HiRes, in fractions of a second, on the same timer perl's own alarm sets. What is guaranteed: the outer alarm is moved by no more than the time await itself takes to read and to set it -- microseconds, each time -- and never by rounding. That matters: perl's alarm answers what is left rounded to a whole second, 9.8 as 10, and setting that again after every await would push the alarm ahead of a row of quick awaits for good. The handler of a Perl signal runs between two operations, so an alarm that falls due while the loop is inside a blocking C call fires when that call returns.

_tick_loop

sub _tick_loop { EV::run(EV::RUN_ONCE()) }

The one genuinely transport-specific seam: run the event loop for one iteration. Called by "await" until the Future is ready.

Croaks unless overridden -- and only from "await", and only for a Future that is not already ready, so a synchronous transport never reaches it.

query_on

my @rows = $h->await( $h->query_on($conn, $sql, \@bind) );

Run $sql on the specific pooled connection $conn (pinned, not released), returning a Future of the raw result rows -- the natural way to assert that a connect action replayed on that connection. $sql uses ? placeholders; shaping them for the wire is the transport's job and happens inside it (ADR 0032 section 6). Wrap the result with "await".

warm_pool

$h->warm_pool;

Spawn every pool connection up front and release them all back to the idle pool, so a later acquire reuses an idle handle instead of spawning one. A pooled *_async op acquires its connection internally, so a test that wants the pool already populated cannot arrange it at the call site.

Connectedness is not what this buys you. "acquire" in DBIO::Storage::PoolBase chains its readiness seam, so an acquire already hands back a connected handle; this only decides when the spawn happens.

Each connection is one "await", each with the full "timeout". An alarm the test file has set stays set through all of them (see "await").

run_on_each_pooled_connection

my @results = $h->run_on_each_pooled_connection($n, sub {
    my ($conn, $harness) = @_;
    return $harness->query_on($conn, $sql);   # a Future
});

The replay-verification seam. Forces $n distinct pool connections to spawn by acquiring and holding them -- each spawn replays the owning sync storage's on_connect actions. Then runs $code->($conn, $self) on each held connection, awaits the returned Future, releases every connection, and returns one entry per connection in spawn order.

Each entry is an arrayref of whatever that connection's Future resolved to -- for a "query_on" op, the arrayref of raw result rows, so $results[$i][0] is connection $i's first row. Capturing per connection keeps multi-row results from flattening across connections.

$code must return a Future. Croaks if the pool's max_size is smaller than $n (raise pool_size in connect_attrs), or if the pool ever hands back a non-distinct connection -- which would mean a spawn did not happen and the replay was never exercised on a fresh connection.

disconnect

Tear down the async backend -- shutting the pool, which runs the on_disconnect actions on each live connection -- and the schema storage.

REUSE BY AN EXTENSION

An async storage extension composes onto a transport via core's storage-layer composition (ADR 0032); it ships no transport of its own. To live-test that its on_connect_call replays on pooled connections, it reuses the transport's harness with its own schema class and its own per-connection assertion:

my $h = DBIO::PostgreSQL::EV::TestHarness->new(
    schema_class  => 'MyApp::Age::Schema',      # registers the extension layer
    connect_attrs => { on_connect_call => 'load_age', pool_size => 3 },
);

The harness never mentions any extension: it exposes the schema, sync storage, async backend and pool, and lets the caller supply the layer and the assertion. This is why a transport's harness belongs under lib/ rather than t/lib/ -- a downstream extension dist cannot see another dist's t/lib.

CAVEAT

This is a live harness: it opens real connections. It is for driver and extension test suites, not production code, and it is deliberately outside core's mock-only offline discipline -- core's own tests exercise this class offline only (parameterisation, gating and error paths), never a connection. Gate every consumer with "skip_all_unless_live".

AUTHOR

DBIO & DBIx::Class Authors

COPYRIGHT AND LICENSE

Copyright (C) 2026 DBIO Authors Portions Copyright (C) 2005-2025 DBIx::Class Authors Based on DBIx::Class, heavily modified.

This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.