view release on metacpan or  search on metacpan

lib/DBIx/QuickORM/Connection.pm  view on Meta::CPAN

        # Used to force a transaction even if there are aside or forked queries running.
        force        => $BOOL, # Basically a combination of the next 2 options
        ignore_aside => $BOOL, # Allow a transaction even if an aside query is active
        ignore_forks => $BOOL, # Allow a transaction even if a forked query is active

        # Things to run at the end of the transaction.
        on_fail       => sub { ... }, # Only runs if the txn is rolled back
        on_success    => sub { ... }, # Only runs if the txn is committed
        on_completion => sub { ... }, # Runs when the txn is done regardless of status.

        # Same as above, except you are adding them to a direct parent txn (if one exists, otherwise they are no-ops)
        on_parent_fail       => sub { ... },
        on_parent_success    => sub { ... },
        on_parent_completion => sub { ... },

        # Same as above, except they are applied to the root transaction, no
        # matter how deeply nested it is.
        on_root_fail       => sub { ... },
        on_root_success    => sub { ... },
        on_root_completion => sub { ... },
    );

An L<DBIx::QuickORM::Connection::Transaction> instance is always returned. If
an action callback was provided then the instance will already be complete, but
you can check and see what the status was. If you did not provide an action
callback then the txn will be "live" and you can use the instance to commit it
or roll it back.

=cut

{
    no warnings 'once';
    *transaction = \&txn;
}
sub txn {
    my $self = shift;
    $self->pid_check;

    my @caller = caller;

    my $cb = (@_ && ref($_[0]) eq 'CODE') ? shift : undef;
    my %params = @_;
    $cb //= $params{action};

    $self->_txn_guards(\%params);

    my $txns = $self->{+TRANSACTIONS};

    my $sp = $self->_txn_begin;

    my $txn = DBIx::QuickORM::Connection::Transaction->new(
        id            => $self->{+_TXN_COUNTER}++,
        savepoint     => $sp,
        trace         => \@caller,
        on_fail       => $params{on_fail},
        on_success    => $params{on_success},
        on_completion => $params{on_completion},
    );

    $self->_txn_attach_relative_callbacks($txn, \%params);

    push @{$txns} => $txn;
    weaken($txns->[-1]);

    my $finalize = $self->_txn_finalizer($sp);

    unless($cb) {
        $txn->set_no_last(1);
        $txn->set_finalize($finalize);
        return $txn;
    }

    local $@;
    my $ok = eval {
        QORM_TRANSACTION: { $cb->($txn) };
        1;
    };

    # The body threw - record the exception that forced the rollback.
    $txn->set_exception($@) unless $ok;

    $finalize->($txn, $ok, $@);

    return $txn;
}

=pod

=item $bool_or_txn = $con->in_transaction

=item $bool_or_txn = $con->in_txn

Returns true if there is a transaction active. If the transaction is managed by
L<DBIx::QuickORM> then the L<DBIx::QuickORM::Connection::Transaction> object
will be returned.

=cut

{
    no warnings 'once';
    *in_transaction = \&in_txn;
}
sub in_txn {
    my $self = shift;
    return $self->current_txn // $self->dialect->in_txn;
}

=pod

=item $txn = $con->current_transaction

=item $txn = $con->current_txn

Return the current L<DBIx::QuickORM::Connection::Transaction> if one is active.

B<Note:> Do not use this to check for a transaction, it will return false if
there is a transaction that is not managed by L<DBIx::QuickORM>.

=cut

lib/DBIx/QuickORM/Connection.pm  view on Meta::CPAN

=pod

=item $con->_txn_guards(\%params)

Croaks when starting a transaction is not currently allowed (active async,
aside, or forked queries). C<force>, C<ignore_aside>, and C<ignore_forks>
params relax the aside/fork checks.

=cut

sub _txn_guards {
    my $self = shift;
    my ($params) = @_;

    croak "Cannot start a transaction while there is an active async query" if $self->{+IN_ASYNC} && !$self->{+IN_ASYNC}->done;

    return if $params->{force};

    unless ($params->{ignore_aside}) {
        my $count = grep { $_ && !$_->done } values %{$self->{+ASIDES} // {}};
        croak "Cannot start a transaction while there is an active aside query (unless you use ignore_aside => 1, or force => 1)" if $count;
    }

    unless ($params->{ignore_forks}) {
        my $count = grep { $_ && !$_->done } values %{$self->{+FORKS} // {}};
        croak "Cannot start a transaction while there is an active forked query (unless you use ignore_forks => 1, or force => 1)" if $count;
    }

    return;
}

=pod

=item $savepoint_or_undef = $con->_txn_begin

Issues the database-side transaction start: a savepoint (returning its name)
when a managed transaction is already open, otherwise a real C<BEGIN>
(returning undef). Croaks when an unmanaged transaction is already open.

=cut

sub _txn_begin {
    my $self = shift;

    my $dialect = $self->dialect;

    if (@{$self->{+TRANSACTIONS}}) {
        my $sp = "SAVEPOINT_${$}_" . $self->{+_SAVEPOINT_COUNTER}++;
        $dialect->create_savepoint(savepoint => $sp);
        return $sp;
    }

    croak "A transaction is already open, but it is not controlled by DBIx::QuickORM" if $dialect->in_txn;

    $dialect->start_txn;
    return undef;
}

=pod

=item $con->_txn_attach_relative_callbacks($txn, \%params)

Attaches C<on_parent_*> callbacks to the current innermost transaction and
C<on_root_*> callbacks to the outermost one. Called before C<$txn> is pushed
onto the stack.

=cut

sub _txn_attach_relative_callbacks {
    my $self = shift;
    my ($txn, $params) = @_;

    my $txns = $self->{+TRANSACTIONS};

    # With an empty stack the new txn is its own root, but it has no parent;
    # on_parent_* callbacks are documented as no-ops in that case. Stack
    # entries are weak references, so check definedness before using them.
    my $parent = @$txns ? $txns->[-1] : undef;
    my $root   = @$txns ? $txns->[0]  : $txn;

    if ($parent) {
        $parent->add_fail_callback($params->{'on_parent_fail'})             if $params->{on_parent_fail};
        $parent->add_success_callback($params->{'on_parent_success'})       if $params->{on_parent_success};
        $parent->add_completion_callback($params->{'on_parent_completion'}) if $params->{on_parent_completion};
    }

    if ($root) {
        $root->add_fail_callback($params->{'on_root_fail'})             if $params->{on_root_fail};
        $root->add_success_callback($params->{'on_root_success'})       if $params->{on_root_success};
        $root->add_completion_callback($params->{'on_root_completion'}) if $params->{on_root_completion};
    }

    return;
}

=pod

=item $cb = $con->_txn_finalizer($savepoint_or_undef)

Builds the one-shot finalize callback that pops the transaction off the
stack, commits or rolls back (savepoint or real transaction), and fires the
transaction's callbacks via C<terminate>.

=cut

sub _txn_finalizer {
    my $self = shift;
    my ($sp) = @_;

    my $txns    = $self->{+TRANSACTIONS};
    my $dialect = $self->dialect;

    my $ran = 0;
    return sub {
        my ($txnx, $ok, @errors) = @_;

        return if $ran;

        # Guards must run before the one-shot state is consumed so a failed
        # commit/rollback (e.g. during an active async query) leaves the
        # transaction recoverable by a later commit/rollback.
        $txnx->throw("Cannot stop a transaction while there is an active async query")
            if $self->{+IN_ASYNC} && !$self->{+IN_ASYNC}->done;

        $txnx->throw("Internal Error: Transaction stack mismatch")
            unless @$txns && (($txnx->in_destroy && !$txns->[-1]) || $txns->[-1] == $txnx);

        $ran++;
        pop @$txns;

        my $aborted = $txnx->aborted;
        my $res     = $ok && !$aborted;

        if ($sp) {
            if   ($res) { $dialect->commit_savepoint(savepoint => $sp) }
            else        { $dialect->rollback_savepoint(savepoint => $sp) }
        }
        else {
            if   ($res) { $dialect->commit_txn }
            else        { $dialect->rollback_txn }
        }

        my ($ok2, $err2) = $txnx->terminate($res, \@errors);
        unless ($ok2) {
            $ok = 0;
            push @errors => @$err2;
        }

        return if $ok;

        # When the transaction fell out of scope, DESTROY runs this as a safety
        # net and has already rolled it back. We cannot propagate an exception
        # from a destructor (Perl turns it into a noisy "(in cleanup)" stack
        # trace), so warn concisely instead of confessing.
        if ($txnx->in_destroy) {
            my $trace = $txnx->trace // [];
            carp "Transaction started at $trace->[1] line $trace->[2] fell out of scope and was rolled back"
                if @$trace > 2;
            return;
        }

        $txnx->throw(join "\n" => @errors);