view release on metacpan or  search on metacpan

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

        $txn = $con->auto_retry_txn({count => 2}, sub { die "boom\n" unless ++$calls > 2 });
    };
    is($calls, 3, "(\\\%params, sub) form respected count from the params hashref");
    is($warnings, 2, "warned once per retry");
    ok($txn->committed, "retried transaction eventually committed");

    $calls = 0;
    $done  = 0;
    $txn = $con->auto_retry_txn(count => 2, on_completion => sub { $done++ }, action => sub { $calls++ });
    is($calls, 1, "(\%params with action) form ran the action once");
    is($done, 1, "(\%params with action) form passed params through to txn()");

    $calls = 0;
    $txn = $con->auto_retry_txn(2, sub { $calls++ });
    is($calls, 1, "(\$count, sub) form ran the action once");

    $calls = 0;
    $txn = $con->auto_retry_txn(2, {action => sub { $calls++ }});
    is($calls, 1, "(\$count, \\\%params) form ran the action once");

    my $err = dies { $con->auto_retry_txn(2, \"nope") };
    like($err, qr/Not sure what to do with second argument/, "bad second argument croaks");
};

{
    package My::Test::FakeAsync;
    sub new { my ($class, %p) = @_; return bless {%p}, $class }
    sub done { $_[0]->{done} }
    sub set_done { $_[0]->{done} = $_[1] }
}

subtest failed_commit_is_recoverable => sub {
    my $con = connect_orm();

    my $txn = $con->txn();
    $con->handle('things')->insert({name => 'wedge'});

    my $fake = My::Test::FakeAsync->new(done => 0);
    $con->{in_async} = $fake;

    my $err = dies { $txn->commit };
    like($err, qr/Cannot stop a transaction while there is an active async query/, "commit during an active async query throws");

    ok(!$txn->complete, "transaction is still open after the failed commit");
    is(scalar(@{$con->transactions}), 1, "transaction is still on the stack");

    $fake->set_done(1);

    ok(lives { $txn->rollback }, "rollback still works after the async query completes") or diag $@;
    ok($txn->complete, "transaction is complete after rollback");
    ok($txn->rolled_back, "transaction rolled back");
    is(scalar(@{$con->transactions}), 0, "transaction stack is clean");
    ok(!$con->dialect->in_txn, "no transaction left open on the database");

    my $dbh = DBI->connect($dsn, '', '', {RaiseError => 1, PrintError => 0});
    my ($count) = $dbh->selectrow_array("SELECT COUNT(*) FROM things WHERE name = 'wedge'");
    $dbh->disconnect;
    is($count, 0, "the insert really was rolled back");
};

subtest on_parent_callbacks => sub {
    my $con = connect_orm();

    my %fired;
    my $ok = eval {
        $con->txn(
            on_parent_fail       => sub { $fired{parent_fail}++ },
            on_parent_completion => sub { $fired{parent_completion}++ },
            on_root_fail         => sub { $fired{root_fail}++ },
            on_root_completion   => sub { $fired{root_completion}++ },
            action               => sub { die "boom\n" },
        );
        1;
    };
    ok(!$ok, "root transaction failed");
    is(\%fired, {root_fail => 1, root_completion => 1}, "on_parent_* are no-ops without a parent, on_root_* fire on self");

    %fired = ();
    $con->txn(sub {
        $con->txn(
            on_parent_success    => sub { $fired{parent_success}++ },
            on_parent_completion => sub { $fired{parent_completion}++ },
            action               => sub { 1 },
        );
        is(\%fired, {}, "parent callbacks have not fired before the parent completes");
    });
    is(\%fired, {parent_success => 1, parent_completion => 1}, "on_parent_* attach to the real parent when nested");
};

subtest already_complete_croaks => sub {
    my $con = connect_orm();

    my $txn = $con->txn();
    $txn->commit;
    ok($txn->complete, "transaction completed");

    my $err = dies { $txn->commit };
    like($err, qr/Transaction is already complete/, "second commit croaks instead of 'Label not found'");

    $err = dies { $txn->rollback };
    like($err, qr/Transaction is already complete/, "rollback after completion croaks too");
};

subtest savepoint_metadata_survives_completion => sub {
    my $con = connect_orm();

    my $saw;
    $con->txn(sub {
        $con->txn(
            on_completion => sub { my $t = shift; $saw = $t->is_savepoint },
            action        => sub { 1 },
        );
    });

    is($saw, 1, "post-completion callbacks still see is_savepoint true for a savepoint txn");
};

done_testing;