[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage.pm

package DBIx::Class::Storage;

use strict;
use warnings;

use base qw/DBIx::Class/;
use mro 'c3';

{
  package # Hide from PAUSE
    DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
  use base 'DBIx::Class::Exception';
}

use DBIx::Class::Carp;
use Scalar::Util qw/blessed weaken/;
use DBIx::Class::Storage::TxnScopeGuard;
use Try::Tiny;
use namespace::clean;

__PACKAGE__->mk_group_accessors(simple => qw/debug schema transaction_depth auto_savepoint savepoints/);
__PACKAGE__->mk_group_accessors(component_class => 'cursor_class');

__PACKAGE__->cursor_class('DBIx::Class::Cursor');

sub cursor { shift->cursor_class(@_); }

=head1 NAME

DBIx::Class::Storage - Generic Storage Handler

=head1 DESCRIPTION

A base implementation of common Storage methods.  For specific
information about L<DBI>-based storage, see L<DBIx::Class::Storage::DBI>.

=head1 METHODS

=head2 new

Arguments: $schema

Instantiates the Storage object.

=cut

sub new {
  my ($self, $schema) = @_;

  $self = ref $self if ref $self;

  my $new = bless( {
    transaction_depth => 0,
    savepoints => [],
  }, $self);

  $new->set_schema($schema);
  $new->debug(1)
    if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} || $ENV{DBIC_TRACE};

  $new;
}

=head2 set_schema

Used to reset the schema class or object which owns this
storage object, such as during L<DBIx::Class::Schema/clone>.

=cut

sub set_schema {
  my ($self, $schema) = @_;
  $self->schema($schema);
  weaken $self->{schema} if ref $self->{schema};
}

=head2 connected

Returns true if we have an open storage connection, false
if it is not (yet) open.

=cut

sub connected { die "Virtual method!" }

=head2 disconnect

Closes any open storage connection unconditionally.

=cut

sub disconnect { die "Virtual method!" }

=head2 ensure_connected

Initiate a connection to the storage if one isn't already open.

=cut

sub ensure_connected { die "Virtual method!" }

=head2 throw_exception

Throws an exception - croaks.

=cut

sub throw_exception {
  my $self = shift;

  if (ref $self and $self->schema) {
    $self->schema->throw_exception(@_);
  }
  else {
    DBIx::Class::Exception->throw(@_);
  }
}

=head2 txn_do

=over 4

=item Arguments: C<$coderef>, @coderef_args?

=item Return Value: The return value of $coderef

=back

Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
returning its result (if any). If an exception is caught, a rollback is issued
and the exception is rethrown. If the rollback fails, (i.e. throws an
exception) an exception is thrown that includes a "Rollback failed" message.

For example,

  my $author_rs = $schema->resultset('Author')->find(1);
  my @titles = qw/Night Day It/;

  my $coderef = sub {
    # If any one of these fails, the entire transaction fails
    $author_rs->create_related('books', {
      title => $_
    }) foreach (@titles);

    return $author->books;
  };

  my $rs;
  try {
    $rs = $schema->txn_do($coderef);
  } catch {
    my $error = shift;
    # Transaction failed
    die "something terrible has happened!"
      if ($error =~ /Rollback failed/);          # Rollback failed

    deal_with_failed_transaction();
  };

In a nested transaction (calling txn_do() from within a txn_do() coderef) only
the outermost transaction will issue a L</txn_commit>, and txn_do() can be
called in void, scalar and list context and it will behave as expected.

Please note that all of the code in your coderef, including non-DBIx::Class
code, is part of a transaction.  This transaction may fail out halfway, or
it may get partially double-executed (in the case that our DB connection
failed halfway through the transaction, in which case we reconnect and
restart the txn).  Therefore it is best that any side-effects in your coderef
are idempotent (that is, can be re-executed multiple times and get the
same result), and that you check up on your side-effects in the case of
transaction failure.

=cut

sub txn_do {
  my $self = shift;
  my $coderef = shift;

  ref $coderef eq 'CODE' or $self->throw_exception
    ('$coderef must be a CODE reference');

  my $abort_txn = sub {
    my ($self, $exception) = @_;

    my $rollback_exception = try { $self->txn_rollback; undef } catch { shift };

    if ( $rollback_exception and (
      ! defined blessed $rollback_exception
          or
      ! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
    ) ) {
      $self->throw_exception(
        "Transaction aborted: ${exception}. "
        . "Rollback failed: ${rollback_exception}"
      );
    }
    $self->throw_exception($exception);
  };

  # take a ref instead of a copy, to preserve coderef @_ aliasing semantics
  my $args = \@_;

  # do not turn on until a succesful txn_begin
  my $attempt_commit = 0;

  my $txn_init_depth = $self->transaction_depth;

  try {
    $self->txn_begin;
    $attempt_commit = 1;
    $coderef->(@$args)
  }
  catch {
    $attempt_commit = 0;

    # init depth of > 0 implies nesting or non-autocommit (either way no retry)
    if($txn_init_depth or $self->connected ) {
      $abort_txn->($self, $_);
    }
    else {
      carp "Retrying txn_do($coderef) after catching disconnected exception: $_"
        if $ENV{DBIC_STORAGE_RETRY_DEBUG};

      $self->_populate_dbh;

      # if txn_depth is > 1 this means something was done to the
      # original $dbh, otherwise we would not get past the if() above
      $self->throw_exception(sprintf
        'Unexpected transaction depth of %d on freshly connected handle',
        $self->transaction_depth,
      ) if $self->transaction_depth;

      $self->txn_begin;
      $attempt_commit = 1;

      try {
        $coderef->(@$args)
      }
      catch {
        $attempt_commit = 0;
        $abort_txn->($self, $_)
      };
    };
  }
  finally {
    if ($attempt_commit) {
      my $delta_txn = (1 + $txn_init_depth) - $self->transaction_depth;

      if ($delta_txn) {
        # a rollback in a top-level txn_do is valid-ish (seen in the wild and our own tests)
        carp "Unexpected reduction of transaction depth by $delta_txn after execution of $coderef, skipping txn_do's commit"
          unless $delta_txn == 1 and $self->transaction_depth == 0;
      }
      else {
        $self->txn_commit;
      }
    }
  };
}

=head2 txn_begin

Starts a transaction.

See the preferred L</txn_do> method, which allows for
an entire code block to be executed transactionally.

=cut

sub txn_begin {
  my $self = shift;

  if($self->transaction_depth == 0) {
    $self->debugobj->txn_begin()
      if $self->debug;
    $self->_exec_txn_begin;
  }
  elsif ($self->auto_savepoint) {
    $self->svp_begin;
  }
  $self->{transaction_depth}++;

}

=head2 txn_commit

Issues a commit of the current transaction.

It does I<not> perform an actual storage commit unless there's a DBIx::Class
transaction currently in effect (i.e. you called L</txn_begin>).

=cut

sub txn_commit {
  my $self = shift;

  if ($self->transaction_depth == 1) {
    $self->debugobj->txn_commit() if $self->debug;
    $self->_exec_txn_commit;
    $self->{transaction_depth}--;
  }
  elsif($self->transaction_depth > 1) {
    $self->{transaction_depth}--;
    $self->svp_release if $self->auto_savepoint;
  }
  else {
    $self->throw_exception( 'Refusing to commit without a started transaction' );
  }
}

=head2 txn_rollback

Issues a rollback of the current transaction. A nested rollback will
throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
which allows the rollback to propagate to the outermost transaction.

=cut

sub txn_rollback {
  my $self = shift;

  if ($self->transaction_depth == 1) {
    $self->debugobj->txn_rollback() if $self->debug;
    $self->_exec_txn_rollback;
    $self->{transaction_depth}--;
  }
  elsif ($self->transaction_depth > 1) {
    $self->{transaction_depth}--;

    if ($self->auto_savepoint) {
      $self->svp_rollback;
      $self->svp_release;
    }
    else {
      DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->throw(
        "A txn_rollback in nested transaction is ineffective! (depth $self->{transaction_depth})"
      );
    }
  }
  else {
    $self->throw_exception( 'Refusing to roll back without a started transaction' );
  }
}

=head2 svp_begin

Arguments: $savepoint_name?

Created a new savepoint using the name provided as argument. If no name
is provided, a random name will be used.

=cut

sub svp_begin {
  my ($self, $name) = @_;

  $self->throw_exception ("You can't use savepoints outside a transaction")
    unless $self->transaction_depth;

  my $exec = $self->can('_exec_svp_begin')
    or $self->throw_exception ("Your Storage implementation doesn't support savepoints");

  $name = $self->_svp_generate_name
    unless defined $name;

  push @{ $self->{savepoints} }, $name;

  $self->debugobj->svp_begin($name) if $self->debug;

  $exec->($self, $name);
}

sub _svp_generate_name {
  my ($self) = @_;
  return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
}


=head2 svp_release

Arguments: $savepoint_name?

Release the savepoint provided as argument. If none is provided,
release the savepoint created most recently. This will implicitly
release all savepoints created after the one explicitly released as well.

=cut

sub svp_release {
  my ($self, $name) = @_;

  $self->throw_exception ("You can't use savepoints outside a transaction")
    unless $self->transaction_depth;

  my $exec = $self->can('_exec_svp_release')
    or $self->throw_exception ("Your Storage implementation doesn't support savepoints");

  if (defined $name) {
    my @stack = @{ $self->savepoints };
    my $svp;

    do { $svp = pop @stack } until $svp eq $name;

    $self->throw_exception ("Savepoint '$name' does not exist")
      unless $svp;

    $self->savepoints(\@stack); # put back what's left
  }
  else {
    $name = pop @{ $self->savepoints }
      or $self->throw_exception('No savepoints to release');;
  }

  $self->debugobj->svp_release($name) if $self->debug;

  $exec->($self, $name);
}

=head2 svp_rollback

Arguments: $savepoint_name?

Rollback to the savepoint provided as argument. If none is provided,
rollback to the savepoint created most recently. This will implicitly
release all savepoints created after the savepoint we rollback to.

=cut

sub svp_rollback {
  my ($self, $name) = @_;

  $self->throw_exception ("You can't use savepoints outside a transaction")
    unless $self->transaction_depth;

  my $exec = $self->can('_exec_svp_rollback')
    or $self->throw_exception ("Your Storage implementation doesn't support savepoints");

  if (defined $name) {
    my @stack = @{ $self->savepoints };
    my $svp;

    # a rollback doesn't remove the named savepoint,
    # only everything after it
    while (@stack and $stack[-1] ne $name) {
      pop @stack
    };

    $self->throw_exception ("Savepoint '$name' does not exist")
      unless @stack;

    $self->savepoints(\@stack); # put back what's left
  }
  else {
    $name = $self->savepoints->[-1]
      or $self->throw_exception('No savepoints to rollback');;
  }

  $self->debugobj->svp_rollback($name) if $self->debug;

  $exec->($self, $name);
}

=begin comment

    =head2 txn_scope_guard

    An alternative way of transaction handling based on
    L<DBIx::Class::Storage::TxnScopeGuard>:

     my $txn_guard = $storage->txn_scope_guard;

     $row->col1("val1");
     $row->update;

     $txn_guard->commit;

    If an exception occurs, or the guard object otherwise leaves the scope
    before C<< $txn_guard->commit >> is called, the transaction will be rolled
    back by an explicit L</txn_rollback> call. In essence this is akin to
    using a L</txn_begin>/L</txn_commit> pair, without having to worry
    about calling L</txn_rollback> at the right places. Note that since there
    is no defined code closure, there will be no retries and other magic upon
    database disconnection. If you need such functionality see L</txn_do>.

=end comment

=cut

sub txn_scope_guard {
  return DBIx::Class::Storage::TxnScopeGuard->new($_[0]);
}

=head2 sql_maker

Returns a C<sql_maker> object - normally an object of class
C<DBIx::Class::SQLMaker>.

=cut

sub sql_maker { die "Virtual method!" }

=head2 debug

Causes trace information to be emitted on the L</debugobj> object.
(or C<STDERR> if L</debugobj> has not specifically been set).

This is the equivalent to setting L</DBIC_TRACE> in your
shell environment.

=head2 debugfh

Set or retrieve the filehandle used for trace/debug output.  This should be
an IO::Handle compatible object (only the C<print> method is used.  Initially
set to be STDERR - although see information on the
L<DBIC_TRACE> environment variable.

=cut

sub debugfh {
    my $self = shift;

    if ($self->debugobj->can('debugfh')) {
        return $self->debugobj->debugfh(@_);
    }
}

=head2 debugobj

Sets or retrieves the object used for metric collection. Defaults to an instance
of L<DBIx::Class::Storage::Statistics> that is compatible with the original
method of using a coderef as a callback.  See the aforementioned Statistics
class for more information.

=cut

sub debugobj {
  my $self = shift;

  if (@_) {
    return $self->{debugobj} = $_[0];
  }

  $self->{debugobj} ||= do {
    if (my $profile = $ENV{DBIC_TRACE_PROFILE}) {
      require DBIx::Class::Storage::Debug::PrettyPrint;
      if ($profile =~ /^\.?\//) {
        require Config::Any;

        my $cfg = try {
          Config::Any->load_files({ files => [$profile], use_ext => 1 });
        } catch {
          # sanitize the error message a bit
          $_ =~ s/at \s+ .+ Storage\.pm \s line \s \d+ $//x;
          $self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_");
        };

        DBIx::Class::Storage::Debug::PrettyPrint->new(values %{$cfg->[0]});
      }
      else {
        DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => $profile });
      }
    }
    else {
      require DBIx::Class::Storage::Statistics;
      DBIx::Class::Storage::Statistics->new
    }
  };
}

=head2 debugcb

Sets a callback to be executed each time a statement is run; takes a sub
reference.  Callback is executed as $sub->($op, $info) where $op is
SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.

See L</debugobj> for a better way.

=cut

sub debugcb {
    my $self = shift;

    if ($self->debugobj->can('callback')) {
        return $self->debugobj->callback(@_);
    }
}

=head2 cursor_class

The cursor class for this Storage object.

=cut

=head2 deploy

Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
Storage class). This would normally be called through
L<DBIx::Class::Schema/deploy>.

=cut

sub deploy { die "Virtual method!" }

=head2 connect_info

The arguments of C<connect_info> are always a single array reference,
and are Storage-handler specific.

This is normally accessed via L<DBIx::Class::Schema/connection>, which
encapsulates its argument list in an arrayref before calling
C<connect_info> here.

=cut

sub connect_info { die "Virtual method!" }

=head2 select

Handle a select statement.

=cut

sub select { die "Virtual method!" }

=head2 insert

Handle an insert statement.

=cut

sub insert { die "Virtual method!" }

=head2 update

Handle an update statement.

=cut

sub update { die "Virtual method!" }

=head2 delete

Handle a delete statement.

=cut

sub delete { die "Virtual method!" }

=head2 select_single

Performs a select, fetch and return of data - handles a single row
only.

=cut

sub select_single { die "Virtual method!" }

=head2 columns_info_for

Returns metadata for the given source's columns.  This
is *deprecated*, and will be removed before 1.0.  You should
be specifying the metadata yourself if you need it.

=cut

sub columns_info_for { die "Virtual method!" }

=head1 ENVIRONMENT VARIABLES

=head2 DBIC_TRACE

If C<DBIC_TRACE> is set then trace information
is produced (as when the L</debug> method is set).

If the value is of the form C<1=/path/name> then the trace output is
written to the file C</path/name>.

This environment variable is checked when the storage object is first
created (when you call connect on your schema).  So, run-time changes
to this environment variable will not take effect unless you also
re-connect on your schema.

=head2 DBIC_TRACE_PROFILE

If C<DBIC_TRACE_PROFILE> is set, L<DBIx::Class::Storage::Debug::PrettyPrint>
will be used to format the output from C<DBIC_TRACE>.  The value it
is set to is the C<profile> that it will be used.  If the value is a
filename the file is read with L<Config::Any> and the results are
used as the configuration for tracing.  See L<SQL::Abstract::Tree/new>
for what that structure should look like.


=head2 DBIX_CLASS_STORAGE_DBI_DEBUG

Old name for DBIC_TRACE

=head1 SEE ALSO

L<DBIx::Class::Storage::DBI> - reference storage implementation using
SQL::Abstract and DBI.

=head1 AUTHORS

Matt S. Trout <mst@shadowcatsystems.co.uk>

Andy Grundman <andy@hybridized.org>

=head1 LICENSE

You may distribute this code under the same terms as Perl itself.

=cut

1;
Commit	Line	Data
4012acd8	1	package DBIx::Class::Storage;
a62cf8d4	2
	3	use strict;
	4	use warnings;
	5
046ad905	6	use base qw/DBIx::Class/;
2ad62d97	7	use mro 'c3';
046ad905	8
90d7422f	9	{
	10	package # Hide from PAUSE
	11	DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
	12	use base 'DBIx::Class::Exception';
	13	}
	14
	15	use DBIx::Class::Carp;
	16	use Scalar::Util qw/blessed weaken/;
1bc193ac	17	use DBIx::Class::Storage::TxnScopeGuard;
f43ea814	18	use Try::Tiny;
fd323bf1	19	use namespace::clean;
046ad905	20
90d7422f	21	__PACKAGE__->mk_group_accessors(simple => qw/debug schema transaction_depth auto_savepoint savepoints/);
90d7422f	22	__PACKAGE__->mk_group_accessors(component_class => 'cursor_class');
e4eb8ee1	23
	24	__PACKAGE__->cursor_class('DBIx::Class::Cursor');
	25
	26	sub cursor { shift->cursor_class(@_); }
046ad905	27
046ad905	28	=head1 NAME
	29
	30	DBIx::Class::Storage - Generic Storage Handler
	31
	32	=head1 DESCRIPTION
	33
	34	A base implementation of common Storage methods. For specific
	35	information about L<DBI>-based storage, see L<DBIx::Class::Storage::DBI>.
	36
	37	=head1 METHODS
	38
	39	=head2 new
	40
	41	Arguments: $schema
	42
	43	Instantiates the Storage object.
	44
	45	=cut
	46
	47	sub new {
	48	my ($self, $schema) = @_;
	49
	50	$self = ref $self if ref $self;
	51
90d7422f	52	my $new = bless( {
	53	transaction_depth => 0,
	54	savepoints => [],
	55	}, $self);
046ad905	56
046ad905	57	$new->set_schema($schema);
4d753fb8	58	$new->debug(1)
4d753fb8	59	if $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG} \|\| $ENV{DBIC_TRACE};
046ad905	60
	61	$new;
	62	}
	63
	64	=head2 set_schema
	65
	66	Used to reset the schema class or object which owns this
	67	storage object, such as during L<DBIx::Class::Schema/clone>.
	68
	69	=cut
	70
	71	sub set_schema {
	72	my ($self, $schema) = @_;
	73	$self->schema($schema);
6298a324	74	weaken $self->{schema} if ref $self->{schema};
046ad905	75	}
	76
	77	=head2 connected
	78
	79	Returns true if we have an open storage connection, false
	80	if it is not (yet) open.
	81
	82	=cut
	83
a62cf8d4	84	sub connected { die "Virtual method!" }
046ad905	85
	86	=head2 disconnect
	87
	88	Closes any open storage connection unconditionally.
	89
	90	=cut
	91
	92	sub disconnect { die "Virtual method!" }
	93
	94	=head2 ensure_connected
	95
	96	Initiate a connection to the storage if one isn't already open.
	97
	98	=cut
	99
a62cf8d4	100	sub ensure_connected { die "Virtual method!" }
046ad905	101
	102	=head2 throw_exception
	103
	104	Throws an exception - croaks.
	105
	106	=cut
	107
	108	sub throw_exception {
	109	my $self = shift;
	110
2a2a7b23	111	if (ref $self and $self->schema) {
1a58752c	112	$self->schema->throw_exception(@_);
	113	}
	114	else {
	115	DBIx::Class::Exception->throw(@_);
	116	}
046ad905	117	}
a62cf8d4	118
4012acd8	119	=head2 txn_do
a62cf8d4	120
4012acd8	121	=over 4
a62cf8d4	122
4012acd8	123	=item Arguments: C<$coderef>, @coderef_args?
a62cf8d4	124
4012acd8	125	=item Return Value: The return value of $coderef
	126
	127	=back
	128
	129	Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
	130	returning its result (if any). If an exception is caught, a rollback is issued
	131	and the exception is rethrown. If the rollback fails, (i.e. throws an
	132	exception) an exception is thrown that includes a "Rollback failed" message.
	133
	134	For example,
	135
	136	my $author_rs = $schema->resultset('Author')->find(1);
	137	my @titles = qw/Night Day It/;
	138
	139	my $coderef = sub {
	140	# If any one of these fails, the entire transaction fails
	141	$author_rs->create_related('books', {
	142	title => $_
	143	}) foreach (@titles);
	144
	145	return $author->books;
	146	};
	147
	148	my $rs;
20674fcd	149	try {
4012acd8	150	$rs = $schema->txn_do($coderef);
20674fcd	151	} catch {
6b89ee0b	152	my $error = shift;
20674fcd	153	# Transaction failed
90d7422f	154	die "something terrible has happened!"
6b89ee0b	155	if ($error =~ /Rollback failed/); # Rollback failed
4012acd8	156
4012acd8	157	deal_with_failed_transaction();
20674fcd	158	};
4012acd8	159
	160	In a nested transaction (calling txn_do() from within a txn_do() coderef) only
	161	the outermost transaction will issue a L</txn_commit>, and txn_do() can be
	162	called in void, scalar and list context and it will behave as expected.
	163
05075aee	164	Please note that all of the code in your coderef, including non-DBIx::Class
	165	code, is part of a transaction. This transaction may fail out halfway, or
	166	it may get partially double-executed (in the case that our DB connection
	167	failed halfway through the transaction, in which case we reconnect and
	168	restart the txn). Therefore it is best that any side-effects in your coderef
	169	are idempotent (that is, can be re-executed multiple times and get the
	170	same result), and that you check up on your side-effects in the case of
	171	transaction failure.
6500d50f	172
4012acd8	173	=cut
	174
	175	sub txn_do {
38ed54cd	176	my $self = shift;
38ed54cd	177	my $coderef = shift;
4012acd8	178
	179	ref $coderef eq 'CODE' or $self->throw_exception
	180	('$coderef must be a CODE reference');
	181
90d7422f	182	my $abort_txn = sub {
90d7422f	183	my ($self, $exception) = @_;
4012acd8	184
90d7422f	185	my $rollback_exception = try { $self->txn_rollback; undef } catch { shift };
4012acd8	186
90d7422f	187	if ( $rollback_exception and (
	188	! defined blessed $rollback_exception
	189	or
	190	! $rollback_exception->isa('DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION')
	191	) ) {
	192	$self->throw_exception(
	193	"Transaction aborted: ${exception}. "
	194	. "Rollback failed: ${rollback_exception}"
	195	);
	196	}
	197	$self->throw_exception($exception);
	198	};
	199
	200	# take a ref instead of a copy, to preserve coderef @_ aliasing semantics
38ed54cd	201	my $args = \@_;
38ed54cd	202
90d7422f	203	# do not turn on until a succesful txn_begin
90d7422f	204	my $attempt_commit = 0;
4012acd8	205
90d7422f	206	my $txn_init_depth = $self->transaction_depth;
	207
	208	try {
	209	$self->txn_begin;
	210	$attempt_commit = 1;
	211	$coderef->(@$args)
52b420dd	212	}
52b420dd	213	catch {
90d7422f	214	$attempt_commit = 0;
4012acd8	215
90d7422f	216	# init depth of > 0 implies nesting or non-autocommit (either way no retry)
	217	if($txn_init_depth or $self->connected ) {
	218	$abort_txn->($self, $_);
	219	}
	220	else {
	221	carp "Retrying txn_do($coderef) after catching disconnected exception: $_"
	222	if $ENV{DBIC_STORAGE_RETRY_DEBUG};
	223
	224	$self->_populate_dbh;
	225
	226	# if txn_depth is > 1 this means something was done to the
	227	# original $dbh, otherwise we would not get past the if() above
	228	$self->throw_exception(sprintf
	229	'Unexpected transaction depth of %d on freshly connected handle',
	230	$self->transaction_depth,
	231	) if $self->transaction_depth;
	232
	233	$self->txn_begin;
	234	$attempt_commit = 1;
	235
	236	try {
	237	$coderef->(@$args)
	238	}
	239	catch {
	240	$attempt_commit = 0;
	241	$abort_txn->($self, $_)
	242	};
	243	};
	244	}
	245	finally {
	246	if ($attempt_commit) {
	247	my $delta_txn = (1 + $txn_init_depth) - $self->transaction_depth;
	248
	249	if ($delta_txn) {
	250	# a rollback in a top-level txn_do is valid-ish (seen in the wild and our own tests)
	251	carp "Unexpected reduction of transaction depth by $delta_txn after execution of $coderef, skipping txn_do's commit"
	252	unless $delta_txn == 1 and $self->transaction_depth == 0;
	253	}
	254	else {
	255	$self->txn_commit;
	256	}
4012acd8	257	}
52b420dd	258	};
a62cf8d4	259	}
a62cf8d4	260
046ad905	261	=head2 txn_begin
	262
	263	Starts a transaction.
	264
	265	See the preferred L</txn_do> method, which allows for
	266	an entire code block to be executed transactionally.
	267
	268	=cut
	269
90d7422f	270	sub txn_begin {
	271	my $self = shift;
	272
	273	if($self->transaction_depth == 0) {
	274	$self->debugobj->txn_begin()
	275	if $self->debug;
	276	$self->_exec_txn_begin;
	277	}
	278	elsif ($self->auto_savepoint) {
	279	$self->svp_begin;
	280	}
	281	$self->{transaction_depth}++;
	282
	283	}
046ad905	284
	285	=head2 txn_commit
	286
	287	Issues a commit of the current transaction.
	288
be01f1be	289	It does I<not> perform an actual storage commit unless there's a DBIx::Class
	290	transaction currently in effect (i.e. you called L</txn_begin>).
	291
046ad905	292	=cut
046ad905	293
90d7422f	294	sub txn_commit {
	295	my $self = shift;
	296
	297	if ($self->transaction_depth == 1) {
	298	$self->debugobj->txn_commit() if $self->debug;
	299	$self->_exec_txn_commit;
	300	$self->{transaction_depth}--;
	301	}
	302	elsif($self->transaction_depth > 1) {
	303	$self->{transaction_depth}--;
	304	$self->svp_release if $self->auto_savepoint;
	305	}
	306	else {
	307	$self->throw_exception( 'Refusing to commit without a started transaction' );
	308	}
	309	}
046ad905	310
	311	=head2 txn_rollback
	312
	313	Issues a rollback of the current transaction. A nested rollback will
	314	throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
	315	which allows the rollback to propagate to the outermost transaction.
	316
	317	=cut
	318
90d7422f	319	sub txn_rollback {
	320	my $self = shift;
	321
	322	if ($self->transaction_depth == 1) {
	323	$self->debugobj->txn_rollback() if $self->debug;
	324	$self->_exec_txn_rollback;
	325	$self->{transaction_depth}--;
	326	}
	327	elsif ($self->transaction_depth > 1) {
	328	$self->{transaction_depth}--;
	329
	330	if ($self->auto_savepoint) {
	331	$self->svp_rollback;
	332	$self->svp_release;
	333	}
	334	else {
	335	DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->throw(
	336	"A txn_rollback in nested transaction is ineffective! (depth $self->{transaction_depth})"
	337	);
	338	}
	339	}
	340	else {
	341	$self->throw_exception( 'Refusing to roll back without a started transaction' );
	342	}
	343	}
046ad905	344
adb3554a	345	=head2 svp_begin
adb3554a	346
360dc8a5	347	Arguments: $savepoint_name?
adb3554a	348
360dc8a5	349	Created a new savepoint using the name provided as argument. If no name
360dc8a5	350	is provided, a random name will be used.
adb3554a	351
	352	=cut
	353
90d7422f	354	sub svp_begin {
	355	my ($self, $name) = @_;
	356
	357	$self->throw_exception ("You can't use savepoints outside a transaction")
	358	unless $self->transaction_depth;
	359
	360	my $exec = $self->can('_exec_svp_begin')
	361	or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
	362
	363	$name = $self->_svp_generate_name
	364	unless defined $name;
	365
	366	push @{ $self->{savepoints} }, $name;
	367
	368	$self->debugobj->svp_begin($name) if $self->debug;
	369
	370	$exec->($self, $name);
	371	}
	372
	373	sub _svp_generate_name {
	374	my ($self) = @_;
	375	return 'savepoint_'.scalar(@{ $self->{'savepoints'} });
	376	}
	377
adb3554a	378
	379	=head2 svp_release
	380
360dc8a5	381	Arguments: $savepoint_name?
adb3554a	382
360dc8a5	383	Release the savepoint provided as argument. If none is provided,
	384	release the savepoint created most recently. This will implicitly
	385	release all savepoints created after the one explicitly released as well.
adb3554a	386
	387	=cut
	388
90d7422f	389	sub svp_release {
	390	my ($self, $name) = @_;
	391
	392	$self->throw_exception ("You can't use savepoints outside a transaction")
	393	unless $self->transaction_depth;
	394
	395	my $exec = $self->can('_exec_svp_release')
	396	or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
	397
	398	if (defined $name) {
	399	my @stack = @{ $self->savepoints };
	400	my $svp;
	401
	402	do { $svp = pop @stack } until $svp eq $name;
	403
	404	$self->throw_exception ("Savepoint '$name' does not exist")
	405	unless $svp;
	406
	407	$self->savepoints(\@stack); # put back what's left
	408	}
	409	else {
	410	$name = pop @{ $self->savepoints }
	411	or $self->throw_exception('No savepoints to release');;
	412	}
	413
	414	$self->debugobj->svp_release($name) if $self->debug;
	415
	416	$exec->($self, $name);
	417	}
adb3554a	418
	419	=head2 svp_rollback
	420
360dc8a5	421	Arguments: $savepoint_name?
adb3554a	422
360dc8a5	423	Rollback to the savepoint provided as argument. If none is provided,
	424	rollback to the savepoint created most recently. This will implicitly
	425	release all savepoints created after the savepoint we rollback to.
adb3554a	426
	427	=cut
	428
90d7422f	429	sub svp_rollback {
	430	my ($self, $name) = @_;
	431
	432	$self->throw_exception ("You can't use savepoints outside a transaction")
	433	unless $self->transaction_depth;
	434
	435	my $exec = $self->can('_exec_svp_rollback')
	436	or $self->throw_exception ("Your Storage implementation doesn't support savepoints");
	437
	438	if (defined $name) {
	439	my @stack = @{ $self->savepoints };
	440	my $svp;
	441
	442	# a rollback doesn't remove the named savepoint,
	443	# only everything after it
	444	while (@stack and $stack[-1] ne $name) {
	445	pop @stack
	446	};
	447
	448	$self->throw_exception ("Savepoint '$name' does not exist")
	449	unless @stack;
	450
	451	$self->savepoints(\@stack); # put back what's left
	452	}
	453	else {
	454	$name = $self->savepoints->[-1]
	455	or $self->throw_exception('No savepoints to rollback');;
	456	}
	457
	458	$self->debugobj->svp_rollback($name) if $self->debug;
	459
	460	$exec->($self, $name);
	461	}
adb3554a	462
a807d012	463	=begin comment
3b7f3eac	464
a807d012	465	=head2 txn_scope_guard
1bc193ac	466
a807d012	467	An alternative way of transaction handling based on
a807d012	468	L<DBIx::Class::Storage::TxnScopeGuard>:
89028f42	469
a807d012	470	my $txn_guard = $storage->txn_scope_guard;
89028f42	471
a807d012	472	$row->col1("val1");
a807d012	473	$row->update;
89028f42	474
a807d012	475	$txn_guard->commit;
89028f42	476
a807d012	477	If an exception occurs, or the guard object otherwise leaves the scope
	478	before C<< $txn_guard->commit >> is called, the transaction will be rolled
	479	back by an explicit L</txn_rollback> call. In essence this is akin to
	480	using a L</txn_begin>/L</txn_commit> pair, without having to worry
	481	about calling L</txn_rollback> at the right places. Note that since there
	482	is no defined code closure, there will be no retries and other magic upon
	483	database disconnection. If you need such functionality see L</txn_do>.
	484
	485	=end comment
1bc193ac	486
	487	=cut
	488
	489	sub txn_scope_guard {
	490	return DBIx::Class::Storage::TxnScopeGuard->new($_[0]);
	491	}
	492
046ad905	493	=head2 sql_maker
	494
	495	Returns a C<sql_maker> object - normally an object of class
d5dedbd6	496	C<DBIx::Class::SQLMaker>.
046ad905	497
	498	=cut
	499
	500	sub sql_maker { die "Virtual method!" }
	501
	502	=head2 debug
	503
f92a9d79	504	Causes trace information to be emitted on the L</debugobj> object.
f92a9d79	505	(or C<STDERR> if L</debugobj> has not specifically been set).
046ad905	506
	507	This is the equivalent to setting L</DBIC_TRACE> in your
	508	shell environment.
	509
	510	=head2 debugfh
	511
	512	Set or retrieve the filehandle used for trace/debug output. This should be
48580715	513	an IO::Handle compatible object (only the C<print> method is used. Initially
046ad905	514	set to be STDERR - although see information on the
	515	L<DBIC_TRACE> environment variable.
	516
	517	=cut
	518
	519	sub debugfh {
	520	my $self = shift;
	521
	522	if ($self->debugobj->can('debugfh')) {
	523	return $self->debugobj->debugfh(@_);
	524	}
	525	}
	526
	527	=head2 debugobj
	528
	529	Sets or retrieves the object used for metric collection. Defaults to an instance
	530	of L<DBIx::Class::Storage::Statistics> that is compatible with the original
	531	method of using a coderef as a callback. See the aforementioned Statistics
	532	class for more information.
	533
4d753fb8	534	=cut
	535
	536	sub debugobj {
	537	my $self = shift;
	538
	539	if (@_) {
	540	return $self->{debugobj} = $_[0];
	541	}
	542
	543	$self->{debugobj} \|\|= do {
	544	if (my $profile = $ENV{DBIC_TRACE_PROFILE}) {
	545	require DBIx::Class::Storage::Debug::PrettyPrint;
	546	if ($profile =~ /^\.?\//) {
	547	require Config::Any;
	548
	549	my $cfg = try {
	550	Config::Any->load_files({ files => [$profile], use_ext => 1 });
	551	} catch {
	552	# sanitize the error message a bit
	553	$_ =~ s/at \s+ .+ Storage\.pm \s line \s \d+ $//x;
	554	$self->throw_exception("Failure processing \$ENV{DBIC_TRACE_PROFILE}: $_");
	555	};
	556
	557	DBIx::Class::Storage::Debug::PrettyPrint->new(values %{$cfg->[0]});
	558	}
	559	else {
	560	DBIx::Class::Storage::Debug::PrettyPrint->new({ profile => $profile });
	561	}
	562	}
	563	else {
	564	require DBIx::Class::Storage::Statistics;
	565	DBIx::Class::Storage::Statistics->new
	566	}
	567	};
	568	}
	569
046ad905	570	=head2 debugcb
	571
	572	Sets a callback to be executed each time a statement is run; takes a sub
	573	reference. Callback is executed as $sub->($op, $info) where $op is
	574	SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
	575
f92a9d79	576	See L</debugobj> for a better way.
046ad905	577
	578	=cut
	579
	580	sub debugcb {
	581	my $self = shift;
	582
	583	if ($self->debugobj->can('callback')) {
	584	return $self->debugobj->callback(@_);
	585	}
	586	}
	587
e4eb8ee1	588	=head2 cursor_class
046ad905	589
	590	The cursor class for this Storage object.
	591
	592	=cut
	593
046ad905	594	=head2 deploy
	595
	596	Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
	597	Storage class). This would normally be called through
	598	L<DBIx::Class::Schema/deploy>.
	599
	600	=cut
	601
	602	sub deploy { die "Virtual method!" }
	603
a3eaff0e	604	=head2 connect_info
	605
	606	The arguments of C<connect_info> are always a single array reference,
	607	and are Storage-handler specific.
	608
	609	This is normally accessed via L<DBIx::Class::Schema/connection>, which
	610	encapsulates its argument list in an arrayref before calling
	611	C<connect_info> here.
	612
	613	=cut
	614
046ad905	615	sub connect_info { die "Virtual method!" }
a3eaff0e	616
	617	=head2 select
	618
	619	Handle a select statement.
	620
	621	=cut
	622
	623	sub select { die "Virtual method!" }
	624
	625	=head2 insert
	626
	627	Handle an insert statement.
	628
	629	=cut
	630
046ad905	631	sub insert { die "Virtual method!" }
a3eaff0e	632
	633	=head2 update
	634
	635	Handle an update statement.
	636
	637	=cut
	638
046ad905	639	sub update { die "Virtual method!" }
a3eaff0e	640
	641	=head2 delete
	642
	643	Handle a delete statement.
	644
	645	=cut
	646
046ad905	647	sub delete { die "Virtual method!" }
a3eaff0e	648
	649	=head2 select_single
	650
	651	Performs a select, fetch and return of data - handles a single row
	652	only.
	653
	654	=cut
	655
046ad905	656	sub select_single { die "Virtual method!" }
a3eaff0e	657
	658	=head2 columns_info_for
	659
c22c7625	660	Returns metadata for the given source's columns. This
	661	is deprecated, and will be removed before 1.0. You should
	662	be specifying the metadata yourself if you need it.
a3eaff0e	663
	664	=cut
	665
046ad905	666	sub columns_info_for { die "Virtual method!" }
	667
	668	=head1 ENVIRONMENT VARIABLES
	669
	670	=head2 DBIC_TRACE
	671
	672	If C<DBIC_TRACE> is set then trace information
f92a9d79	673	is produced (as when the L</debug> method is set).
046ad905	674
	675	If the value is of the form C<1=/path/name> then the trace output is
	676	written to the file C</path/name>.
	677
	678	This environment variable is checked when the storage object is first
fd323bf1	679	created (when you call connect on your schema). So, run-time changes
fd323bf1	680	to this environment variable will not take effect unless you also
046ad905	681	re-connect on your schema.
046ad905	682
b6cd6478	683	=head2 DBIC_TRACE_PROFILE
b6cd6478	684
2514a73f	685	If C<DBIC_TRACE_PROFILE> is set, L<DBIx::Class::Storage::Debug::PrettyPrint>
b6cd6478	686	will be used to format the output from C<DBIC_TRACE>. The value it
	687	is set to is the C<profile> that it will be used. If the value is a
	688	filename the file is read with L<Config::Any> and the results are
	689	used as the configuration for tracing. See L<SQL::Abstract::Tree/new>
	690	for what that structure should look like.
	691
	692
046ad905	693	=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
	694
	695	Old name for DBIC_TRACE
	696
ace385bd	697	=head1 SEE ALSO
ace385bd	698
2f0790c4	699	L<DBIx::Class::Storage::DBI> - reference storage implementation using
2f0790c4	700	SQL::Abstract and DBI.
ace385bd	701
046ad905	702	=head1 AUTHORS
	703
	704	Matt S. Trout <mst@shadowcatsystems.co.uk>
	705
	706	Andy Grundman <andy@hybridized.org>
	707
	708	=head1 LICENSE
	709
	710	You may distribute this code under the same terms as Perl itself.
	711
	712	=cut
	713
a62cf8d4	714	1;