view release on metacpan or  search on metacpan

t/AI/transaction_extra.t  view on Meta::CPAN

        is($txn->state, 'active', "long-lived txn starts active");
        $con->handle('items')->insert({name => 'abandoned'});
        # $txn falls out of scope here while still active.
        $txn = undef;
    };

    ok(!$con->in_txn, "connection no longer in a txn after abandoned txn destroyed");
    is(disk_names(), $before, "abandoned active txn was rolled back on DESTROY");

    # DESTROY-driven rollback is a documented safety net and surfaces a
    # diagnostic noting that the transaction fell out of scope.
    ok(
        (grep { $_ =~ /fell out of scope/i } @$warns),
        "DESTROY rollback warns that the dropped txn fell out of scope",
    ) or diag(explain($warns));
};

subtest auto_retry_returns_value => sub {
    my $calls = 0;
    my $out   = $con->auto_retry(sub { $calls++; return 'the-result' });
    is($out, 'the-result', "auto_retry returns the callback result on success");
    is($calls, 1, "auto_retry ran the callback once on immediate success");
};

subtest auto_retry_in_txn_croaks => sub {
    my $err = dies {
        $con->txn(sub {
            $con->auto_retry(sub { 1 });
        });
    };
    like($err, qr/Cannot use auto_retry inside a transaction/, "auto_retry croaks inside an open txn");
};

subtest auto_retry_txn_persists => sub {
    my $before = disk_names();
    my $txn    = $con->auto_retry_txn(sub {
        $con->handle('items')->insert({name => 'via_retry'});
    });
    isa_ok($txn, ['DBIx::QuickORM::Connection::Transaction'], "auto_retry_txn returns a txn object");
    is($txn->result, 1, "auto_retry_txn committed on success");
    is(disk_names(), [sort(@$before, 'via_retry')], "auto_retry_txn persisted the row");
};

subtest destroy_parent_before_child_savepoint_does_not_wedge => sub {
    # Perl does not guarantee the destruction order of lexicals, so a parent
    # transaction can be destroyed while a child savepoint is still live. That
    # must not leave the root BEGIN open and permanently wedge the connection.
    my $h = $con->handle('items');
    {
        local $SIG{__WARN__} = sub {};    # abandoned txns warn on rollback; expected here
        my $inner;
        { my $outer = $con->txn; $inner = $con->txn; }    # parent (root) destroyed first
        undef $inner;                                     # then the orphaned child
    }

    ok(!$con->in_txn, "no transaction is left open after out-of-order destruction");
    is(scalar(grep { defined } @{$con->transactions}), 0, "the transaction stack is empty");

    ok(lives { $con->txn(sub { $h->insert({name => 'after_wedge'}) }) }, "a later transaction still runs");
    ok(scalar(grep { $_ eq 'after_wedge' } @{disk_names()}), "and its work actually persists to disk");
    ok(lives { $con->reconnect }, "reconnect is not blocked by a phantom active transaction");
};

$probe->disconnect;

done_testing;