File Coverage

blib/lib/DBIx/Transaction/db.pm

Criterion	Covered	Total	%
statement	15	138	10.8
branch	0	38	0.0
condition	0	18	0.0
subroutine	5	22	22.7
pod	13	15	86.6
total	33	231	14.2

#!perl;

package DBIx::Transaction::db;

use DBI;
use base q(DBI::db);
use strict;
use warnings (FATAL => 'all');
use Carp qw(confess croak);

return 1;

sub connected {
    my ( $self, $dsn, $user, $credential, $attrs ) = @_;

    if ( $self->{AutoCommit} ) {
	$self->{private_DBIx_Transaction_AutoCommit} = 1;
    }
    else {
	$self->{private_DBIx_Transaction_AutoCommit} = 0;
    }

    $self->{private_DBIx_Transaction_Level} = 0;
    $self->{private_DBIx_Transaction_Error} = 0;

    my $method = $attrs->{dbi_connect_method} || $DBI::connect_via;

    $self->transaction_trace($method);

    return $self;
}

sub transaction_trace {
    my($self, $method) = @_;
    my @vals = map { "$_=$self->{$_}" } map { "private_DBIx_Transaction_$_" }
        qw(AutoCommit Level Error);

    $self->trace_msg("DBIx::Transaction: $method: " . join(" ", @vals), 3);
}

sub transaction_level {
    my $self = shift;
    return $self->{private_DBIx_Transaction_Level};
}

sub inc_transaction_level {
    my $self = shift;
    $self->{private_DBIx_Transaction_Level}++;
    return $self->{private_DBIx_Transaction_Level};
}

sub dec_transaction_level {
    my $self = shift;
    confess "Asked to decrement transaction level below zero!"
        unless($self->{private_DBIx_Transaction_Level});
    $self->{private_DBIx_Transaction_Level}--;
    return $self->{private_DBIx_Transaction_Level};
}

sub clear_transaction_error {
    my $self = shift;
    $self->{private_DBIx_Transaction_Error} = 0;
    $self->{private_DBIx_Transaction_Error_Caller} = undef;
    return;
}

sub inc_transaction_error {
    my($self, @caller) = @_;
    $self->{private_DBIx_Transaction_Error}++;
    if(@caller) {
        $self->{private_DBIx_Transaction_Error_Caller} ||= [];
        push(@{$self->{private_DBIx_Transaction_Error_Caller}}, \@caller);
    }
    return;
}

sub transaction_error {
    my $self = shift;
    return $self->{private_DBIx_Transaction_Error};
}

sub transaction_error_callers {
    my $self = shift;
    if($self->{private_DBIx_Transaction_Error_Caller}) {
        return @{$self->{private_DBIx_Transaction_Error_Caller}};
    } else {
        return;
    }
}

sub close_transaction {
    my $self = shift;
    my $method = shift;
    my $code = DBI::db->can($method);

    $self->{private_DBIx_Transaction_Level} = 0;
    $self->clear_transaction_error;
    $self->transaction_trace($method);
    my $rv = $code->($self, @_);
    return $rv;
}

sub begin_work {
    my $self = shift;
    if(!$self->transaction_level) {
        $self->inc_transaction_level;
        if($self->{private_DBIx_Transaction_AutoCommit}) {
            $self->transaction_trace('begin_work');
            return DBI::db::begin_work($self, @_);
        } else {
            return 1;
        }
    } else {
        $self->inc_transaction_level;
        $self->transaction_trace('fake_begin_work');
        return 1;
    }
}

sub commit {
    my $self = shift;
    if(my $error = $self->transaction_error) {
        my $err = "commit() called after a transaction error or rollback!";
        if(my @callers = $self->transaction_error_callers) {
            foreach my $i (@callers) {
                $err .= "\nError or rollback at: $i->[1] line $i->[2]";
                if($i->[3]) {
                  $err .= " (Error String: $i->[3])";
                }
            }
        }

        $self->set_err(1, $err);
        return;
    }

    if(my $l = $self->dec_transaction_level) {
        $self->transaction_trace('fake_commit');
        return 1;
    }
    return $self->close_transaction('commit', @_);
}

sub rollback {
    my $self = shift;
    if(my $l = $self->dec_transaction_level) {
        $self->transaction_trace('fake_rollback');
        $self->inc_transaction_error(caller);
        return 1;
    }
    return $self->close_transaction('rollback', @_);
}

sub do {
    my $self = shift;
    my $rv = eval { DBI::db::do($self, @_); };
    if($@) {
        $self->inc_transaction_error(caller, $self->errstr);
        croak $@;
    }
    if(!$rv) {
        $self->inc_transaction_error(caller, $self->errstr);
    }
    return $rv;
}

sub _when {
  my($dbh, $return_value, $return_exception, $tries) = @_;
  my $rv = !!($tries && ($return_exception || !$return_value));
  return $rv;
}

sub transaction {
  my($self, $run, $tries, $when) = @_;
  my($rv, $re);

  my $tried = 0;
  $tries ||= 1;

  if(($tries != 1 || $when) && $self->transaction_level) {
    croak "Transaction retry flow may only be set on the outermost transaction";
  }


  $when ||= \&_when;


  do {
    $self->set_err(0, "Retrying transaction ($tries tries left)")
      if $tried;

    eval { $rv = $self->_transaction($run) };
    $re = $@;
    $tries-- unless $tries <= 0;
    $tried++;
  } while($when->($self, $rv, $re, $tries));

  if($re) {
    die $re;
  } else {
    return $rv;
  }
}

sub _transaction {
  my($self, $run) = @_;
  my $rv;

  $self->begin_work;

  eval { $rv = $run->() };

  if(my $re = $@) {
    $self->rollback;
    croak $re;
  } elsif(!$rv) {
    my $err = $self->err;
    my $errstr = $self->errstr;
    my $state = $self->state;
    $self->rollback;
    $self->set_err($err, $errstr, $state);
  } else {
    $self->commit;
  }

  return $rv;
}

=pod

=head1 NAME

DBIx::Transaction::db - Database handle that is aware of nested transactions

=head1 SYNOPSIS

See L

=head1 DESCRIPTION

When you connect to a database using DBIx::Transaction, your database handle
will be a DBIx::Transaction::db object. These objects keep track of your
transaction state, allowing for transactions to occur within transactions,
and only sending "C" or "C" instructions to the underlying
database when the outermost transaction has completed. See L
for a more complete explanation.

=head1 METHODS

=head2 Overridden Methods

The following methods are overridden by DBIx::Transaction::db:

=over

=item begin_work

Start a transaction.

If there are no transactions currently running, C will check
if C is enabled. If it is enabled, a C instruction
is sent to the underlying database layer. If C is disabled, we
assume that the database has already started a transaction for us, and do
nothing. This means that B
transaction>, even if C is enabled!

If there is a transaction started, C simply records that a nested
transaction has started.

C returns the result of the database's C call if it
makes one; otherwise it always returns true.

=item rollback

Abort a transaction.

If there are no sub-transactions currently running, C will issue the
C call to the underlying database layer.

If there are sub-transactions currently running, C notes that the
nested transaction has been aborted.

If there is no transaction running at all, C will raise a fatal
error.

=item commit

If there are sub-transactions currently running, C records that this
transaction has completed successfully and does nothing to the underlying
database layer.

If there are no sub-transactions currently running, C checks if
there have been any transaction errors. If there has been a transaction
error, C raises an exception. Otherwise, a C call is
issued to the underlying database layer.

If there is no transaction running at all, C will raise a fatal
error. This error will contain a full stack trace, and should also contain
the file names and line numbers where any rollbacks or query failures
happened.

=item do

Calls L on your underlying database handle. If an error
occurs, this is recorded and you will not be able to issue a C
for the current transaction.

=back

=head2 Extra Methods

The following method is provided for convienence in setting up database
transactions:

=over

=item transaction($coderef[, $tries[, $when]])

Execute the code contained inside C<$coderef> within a transaction.
C<$coderef> is expected to return a scalar value.
If C<$coderef> returns true, the transaction is committed. If
C<$coderef> returns false or raises a fatal error, the transaction
is rolled back. The return value is the same as what is returned by
C<$coderef>.

This method is supplied to make it easier to create nested transactions
out of many small transactions. Example:

  sub get_max_id {
    my $dbh = shift;
    # this will roll back if it can't get MAX(num)
    $dbh->transaction(sub {
      if(my($id) = $dbh->selectrow_array("SELECT MAX(num) FROM foo")) {
        return $id;
      } else {
        return;
      }
    });
  }

  sub do_something {
    my($dbh, $num) = @_;
    $dbh->transaction(sub {
      $dbh->do("UPDATE foo SET bar = bar + 1 WHERE num = $num");
    });
  }

  sub do_many_things {
    my $dbh = shift;
    # if any of these sub-transactions roll back, the whole thing will roll
    # back. Try repeating the transaction up to 5 times.
    $dbh->transaction(sub {
      if(
        do_something($dbh, 1) &&
        do_something($dbh, 2) &&
        (my $id = get_max_id($dbh))
      ) {
        return do_something($dbh, $id);
      } else {
        return;
      }
    }, 5);
  }

=over

=item Re-trying transactions

If C<$tries> is specified, the transaction will be tried up to
C<$tries> times before giving up. (Default: 1) Specify a negative
value to re-try forever.

B only the outermost transaction may attempt retries. This
is because if there is one failure within a transaction, the entire
transaction fails -- so any retries in nested transactions would have
to fail, by virtue of the previous attempt failing. If you try to set
up retries from inside a nested transaction, this will die with the
error "Transaction retry flow may only be set on the outermost transaction".

C<$when> is an optional code reference that can be used to decide
if a transaction should be retried or not. It will be passed the
following arguments:

=over

=item The database handle (C<$dbh>)

=item The return value of the transaction

=item The exception raised by the transaction, if any (C<$@>)

=item How many tries are left

=back

If the code reference returns true, the transaction will be run again.
If it returns false, the C<$dbh->transaction()> will finish, either
returning a value, or raising an exception if one was caused by
the last execution of C<$coderef>.

The default handler for C<$when> is simply:

  sub {
    my($dbh, $return_value, $return_exception, $tries) = @_;
    return $tries && ($return_exception || !$return_value);
  }

=back

=back

=head2 Other Methods

The following methods are used by the overridden methods. In most cases
you won't have to use them yourself.

=over

=item transaction_level

Returns an integer value representing how deeply nested our transactions
currently are. eg; if we are in a top-level transaction, this returns "1";
if we are 4 transactions deep, this returns "4", if we are not in a transaction
at all, this returns "0". In some extreme cases this may be used to bail out
of a nested transaction safely, as in:

  $dbh->rollback while $dbh->transaction_level;

But I would suggest that you structure your code so that each transaction
and sub-transaction bails out safely instead, as that's a lot easier to
trace and debug with confidence.

=item transaction_error

Returns a true value if a sub-transaction has rolled back, false otherwise.
Again, you could use this to back out of a transaction safely, but I'd suggest
just writing your code to handle this case on each transaction level instead.

=item transaction_trace

For debugging; If DBI's trace level is 3 or over, emit the current values
of all of the internal variables DBIx::Transaction uses to track it's
transaction states.

=item inc_transaction_level

Indicate that we have started a sub transaction by increasing
C by one. This is used by the C override
and should not be called directly.

=item dec_transaction_level

Indicate that we have finished a sub transaction by decrementing
C by one. If this results in a negative number
(meaning more transactions have been commited/rolled back than started),
C throws a fatal error. This is used by the
C and C methods and should not be called directly.

=item inc_transaction_error

Indicate that a sub-transaction has failed and that the entire
transaction should not be allowed to be committed. This is done
automatically whenever a sub-transaction issues a C.
Optional parameters are the package, filename, and line where
the transaction error occured. If provided, they will be used in
error messages relating to the rollback.

=item clear_transaction_error

Clear the transaction error flag. This flag is set whenever a
sub-transaction issues a C, and cleared whenever the
outermost transaction issues a C.

=item close_transaction($method)

Close the outermost transaction by calling C<$method>
("C" or "C") on the underlying database layer and
resetting the DBIx::Transaction state. This method is used by the
C and C methods and you shouldn't need to use it yourself,
unless you wanted to forcibly bail out of an entire transaction without
calling C repeatedly, but as stated above, that's a bad idea,
isn't it?

=back

=head1 SEE ALSO

L, L

=head1 AUTHOR

Tyler "Crackerjack" MacDonald

=head1 LICENSE

Copyright 2005 Tyler MacDonald
This is free software; you may redistribute it under the same terms as perl itself.

=cut