view release on metacpan or  search on metacpan

lib/DBIx/DataModel/Schema.pm  view on Meta::CPAN

  return wantarray ? @$return_dbh : $return_dbh->[0];
}


sub _handle_SQL_error {
  my ($self, $dbi_errstr, $dbh, $unused) = @_;

  # skip intermediate ORM stack frames so that errors are reported from the caller's perspective
  local %DBIx::DataModel::Carp::CARP_OBJECT_CONSTRUCTOR = (frame_filter => sub {
    my ($frame_ref) = @_; 
    my $pkg = $frame_ref->{caller}[0];
    return 0  if $pkg =~ /^DBIx::DataModel/ or $pkg =~ /^SQL::Abstract/;   # skip packages used by DBIx::DataModel
    return $self->{frame_filter}->($frame_ref) if $self->{frame_filter};   # skip packages specified by client
    return 1;                                                              # otherwise, don't skip
   });

  # re-inject $dbi_errstr also into DBI handles, because some upper levels like DBIx::RetryOverDisconnects 
  # may ignore the error raised by croak and use DBI::errstr instead -- not what we want here !
  no warnings 'uninitialized';
  $dbh->set_err($DBI::err, $dbi_errstr) if $DBI::err and $dbi_errstr ne $DBI::errstr;

  # raise the error through Carp::Object, which will automatically apply the frame filter just set above
  croak $dbi_errstr; 
}

  

sub with_db_schema {
  my ($self, $db_schema) = @_;
  ref $self or $self = $self->singleton;

  # return a shallow copy of $self with db_schema set to the given arg
  return bless { %$self, db_schema => $db_schema}, ref $self;
}


my @default_state_components = qw/dbh debug select_implicitly_for
                                  dbi_prepare_method db_schema/;

sub localize_state {
  my ($self, @components) = @_; 
  ref $self or $self = $self->singleton;

  @components = @default_state_components unless @components;

  my %saved_state;
  $saved_state{$_} = $self->{$_} foreach @components;

  return DBIx::DataModel::Schema::_State->new($self, \%saved_state);
}




sub do_after_commit {
  my ($self, $coderef) = @_;
  ref $self or $self = $self->singleton;

  $self->{transaction_dbhs}
    or croak "do_after_commit() called outside of a transaction";
  push @{$self->{after_commit_callbacks}}, $coderef;
}


sub do_transaction { 
  my ($self, $coderef, @new_dbh) = @_; 
  ref $self or $self = $self->singleton;

  does($coderef, 'CODE')
    or croak 'first arg to $schema->do_transaction(...) should be a coderef';

  my $transaction_dbhs = $self->{transaction_dbhs} ||= [];

  # localize the dbh and its options, if so requested. 
  my $local_state = $self->localize_state(qw/dbh/)
    and
        delete($self->{dbh}),  # cheat so that dbh() does not complain
        $self->dbh(@new_dbh)   # and now update the dbh
    if @new_dbh; # postfix "if" because $local_state must not be in a block

  # check that we have a dbh
  my $dbh = $self->dbh
    or croak "no database handle for transaction";

  # how to call and how to return will depend on context
  my $want = wantarray ? "array" : defined(wantarray) ? "scalar" : "void";
  my $in_context = {
    array  => do {my @array;
                  {call   => sub {@array = $coderef->()}, 
                   return => sub {return @array}}},
    scalar => do {my $scalar;
                  {call   => sub {$scalar = $coderef->()}, 
                   return => sub {return $scalar}}},
    void   =>     {call   => sub {$coderef->()}, 
                   return => sub {return}}
   }->{$want};


  my $begin_work_and_exec = sub {
    # make sure dbh is in transaction mode
    if ($dbh->{AutoCommit}) {
      $dbh->begin_work; # will set AutoCommit to false
      push @$transaction_dbhs, $dbh;
    }

    # do the real work
    $in_context->{call}->();
  };

  if (@$transaction_dbhs) { # if in a nested transaction, just exec
    $begin_work_and_exec->();
  }
  else { # else try to execute and commit in an eval block

    # support for DBIx::RetryOverDisconnects: decide how many retries
    my $n_retries = 1;
    if ($dbh->isa('DBIx::RetryOverDisconnects::db')) {
      $n_retries = $dbh->{DBIx::RetryOverDisconnects::PRIV()}{txn_retries};
    }

    # try to do the transaction, maybe several times in cas of disconnection
  RETRY:
    for my $retry (1 .. $n_retries) {
      no warnings 'exiting'; # because "last/next" are in Try::Tiny subroutines
      try {
        # check AutoCommit state
        $dbh->{AutoCommit}
          or croak "dbh was not in Autocommit mode before initial transaction";

        # execute the transaction
        $begin_work_and_exec->();

        # commit all dbhs and then reset the list of dbhs
        $_->commit foreach @$transaction_dbhs;
        delete $self->{transaction_dbhs};

        last RETRY; # transaction successful, get out of the loop
      }
      catch {
        my $err = $_;

        # if this was a disconnection ..
        if ($dbh->isa('DBIx::RetryOverDisconnects::db') 
              # $dbh->can() is broken on DBI handles, so use ->isa() instead
              && $dbh->is_trans_disconnect) {
          $transaction_dbhs = [];
          next RETRY if $retry < $n_retries;   # .. try again
          $self->exc_conn_trans_fatal->throw;  # .. or no hope (and no rollback)
        }

        # otherwise, for regular SQL errors, try to rollback and then throw
        my @rollback_errs;
        foreach my $dbh (reverse @$transaction_dbhs) {
          try   {$dbh->rollback}
            catch {push @rollback_errs, $_};
        }
        delete $self->{transaction_dbhs};
        delete $self->{after_commit_callbacks};
        DBIx::DataModel::Schema::_Exception->throw($err, @rollback_errs);
      };
    }
  }

  # execute the after_commit callbacks
  my $callbacks = delete $self->{after_commit_callbacks} || [];
  $_->() foreach @$callbacks;

  return $in_context->{return}->();
}


sub unbless {
  my $class = shift;
  Data::Structure::Util::unbless($_) foreach @_;

  return wantarray ? @_ : $_[0];
}


# accessors to connected sources (tables or joins) from the current schema
#                   local method     metadm method
#                   ============     =============
my %accessor_map = (table         => 'table',
                    join          => 'define_join',
                    db_table      => 'db_table');
while (my ($local, $remote) = each %accessor_map) {
  no strict 'refs';
  *$local = sub {
    my $self = shift;
    ref $self or $self = $self->singleton;

    my $meta_source = $self->metadm->$remote(@_) or return;
    my $obj = bless {__schema => $self}, $meta_source->class;
    return $obj;
  }
}

#----------------------------------------------------------------------
# UTILITY FUNCTIONS (PRIVATE)
#----------------------------------------------------------------------


sub _debug { # internal method to send debug messages
  my ($self, $msg) = @_;
  my $debug = $self->debug;
  if ($debug) {
    if (ref $debug && $debug->can('debug')) { $debug->debug($msg) }
    else                                    { carp $msg; }
  }
}





#----------------------------------------------------------------------
# PRIVATE CLASS FOR LOCALIZING STATE (see L</localizeState> method
#----------------------------------------------------------------------

package
  DBIx::DataModel::Schema::_State;

sub new {
  my ($class, $schema, $state) = @_;
  bless [$schema, $state], $class;
}