view release on metacpan or  search on metacpan

t/storage/pool_connect_actions.t  view on Meta::CPAN

{
  package RecHandle;
  sub new { bless { log => $_[1] }, $_[0] }
  sub do  { my ($self, $sql) = @_; push @{ $self->{log} }, $sql; 1 }
}

{
  package RecPool;
  use base 'DBIO::Storage::PoolBase';

  my $NEXT = 0;

  sub _create_connection {
    my ($self, $conninfo) = @_;
    my @log;
    return { id => ++$NEXT, log => \@log, dbh => RecHandle->new(\@log) };
  }

  # Keep the connection (and its log) intact through shutdown so the test can
  # assert on the disconnect actions that ran against it.
  sub _shutdown_connection { }
}

# --- The fake async backend -------------------------------------------------
# Concrete DBIO::Storage::Async that overrides only the seams it needs, wiring
# itself as the RecPool's owner so the central pool-spawn hook can reach it. It
# inherits _setup_pool_connection / _teardown_pool_connection / the default
# _run_pool_connect_statement unchanged.
{
  package RecBackend;
  use base 'DBIO::Storage::Async';

  sub future_class     { 'Future' }
  sub sql_maker_class  { 'DBIO::SQLMaker' }
  sub _transform_sql   { $_[1] }
  sub _post_insert_sql { '' }

  sub pool {
    my $self = shift;
    $self->{pool} ||= RecPool->new(
      storage  => $self,
      conninfo => $self->{_conninfo} || 'fake',
      size     => $self->{_pool_size} || 5,
    );
  }
}

# --- The owning sync storage ------------------------------------------------
# isa DBIO::Storage::DBI, so it carries the on_connect_* accessors and the sync
# _do_connection_actions dispatch. Defines a connect_call_* / disconnect_call_*
# method that emits a known SQL via _do_query -- the exact convention real
# drivers use (connect_call_load_age, connect_call_use_foreign_keys, ...).
{
  package RecOwner;
  use base 'DBIO::Storage::DBI';

  sub connect_call_test_setup       { $_[0]->_do_query('SETUP CALL') }
  sub disconnect_call_test_teardown { $_[0]->_do_query('TEARDOWN CALL') }
}

my $schema = DBIO::Test->init_schema;   # kept alive: storages weaken their ref

sub wired_backend {
  my %config = @_;
  my $backend = RecBackend->new($schema);
  my $owner   = RecOwner->new($schema);

  $owner->on_connect_do($config{on_connect_do})           if exists $config{on_connect_do};
  $owner->on_connect_call($config{on_connect_call})       if exists $config{on_connect_call};
  $owner->on_disconnect_do($config{on_disconnect_do})     if exists $config{on_disconnect_do};
  $owner->on_disconnect_call($config{on_disconnect_call}) if exists $config{on_disconnect_call};

  $backend->_owner_storage($owner);
  $backend->connect_info([ { host => 'h', pool_size => $config{size} || 5 } ]);

  # return the owner too so its weak back-ref stays alive for the caller
  return ($backend, $owner);
}

# ---------------------------------------------------------------------------
# on_connect_do + on_connect_call replay on every freshly spawned connection,
# in the sync dispatch order (call before do), BEFORE the connection serves any
# query.
# ---------------------------------------------------------------------------
{
  my ($backend, $owner) = wired_backend(
    on_connect_call => 'test_setup',
    on_connect_do   => [ 'PRAGMA one', 'PRAGMA two' ],
    size            => 2,
  );

  my @expected = ( 'SETUP CALL', 'PRAGMA one', 'PRAGMA two' );

  my $c1 = $backend->pool->acquire->get;
  is_deeply $c1->{log}, \@expected,
    'first pool connection replayed on_connect_call then on_connect_do at spawn';

  # The replay happened at spawn, i.e. before acquire even resolved -- so it is
  # in place before the first query is ever served on this connection.
  ok scalar(@{ $c1->{log} }), 'connect actions present the moment the connection is handed out';

  # A second physical connection gets its OWN independent replay.
  my $c2 = $backend->pool->acquire->get;
  isnt $c1->{id}, $c2->{id}, 'two distinct physical connections spawned (pool size 2)';
  is_deeply $c2->{log}, \@expected,
    'second pool connection got its own full on_connect replay';

  # Idle reuse must NOT re-run the actions (spawn-only, once per physical conn).
  $backend->pool->release($c1);
  my $reused = $backend->pool->acquire->get;
  is $reused->{id}, $c1->{id}, 'released connection is reused, not re-spawned';
  is_deeply $reused->{log}, \@expected,
    'reused idle connection did not replay the on_connect actions again';
}

# ---------------------------------------------------------------------------
# connect_call dispatch: coderef form and nested-arrayref do_sql form both route
# through _do_query onto the pool connection (mirrors sync resolution order).
# ---------------------------------------------------------------------------
{
  my ($backend, $owner) = wired_backend(