DBIx-Class

 view release on metacpan or  search on metacpan

lib/DBIx/Class/Storage/DBI.pm  view on Meta::CPAN

package DBIx::Class::Storage::DBI;
# -*- mode: cperl; cperl-indent-level: 2 -*-

use strict;
use warnings;

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

use DBIx::Class::Carp;
use Scalar::Util qw/refaddr weaken reftype blessed/;
use Context::Preserve 'preserve_context';
use Try::Tiny;
use SQL::Abstract::Util qw(is_plain_value is_literal_value);
use DBIx::Class::_Util qw(quote_sub perlstring serialize detected_reinvoked_destructor sigwarn_silencer);
use namespace::clean;

# default cursor class, overridable in connect_info attributes
__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');

__PACKAGE__->mk_group_accessors('inherited' => qw/
  sql_limit_dialect sql_quote_char sql_name_sep
/);

__PACKAGE__->mk_group_accessors('component_class' => qw/sql_maker_class datetime_parser_type/);

__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker');
__PACKAGE__->datetime_parser_type('DateTime::Format::MySQL'); # historic default

__PACKAGE__->sql_name_sep('.');

__PACKAGE__->mk_group_accessors('simple' => qw/
  _connect_info _dbic_connect_attributes _driver_determined
  _dbh _dbh_details _conn_pid _sql_maker _sql_maker_opts _dbh_autocommit
  _perform_autoinc_retrieval _autoinc_supplied_for_op
/);

# the values for these accessors are picked out (and deleted) from
# the attribute hashref passed to connect_info
my @storage_options = qw/
  on_connect_call on_disconnect_call on_connect_do on_disconnect_do
  disable_sth_caching unsafe auto_savepoint
/;
__PACKAGE__->mk_group_accessors('simple' => @storage_options);


# capability definitions, using a 2-tiered accessor system
# The rationale is:
#
# A driver/user may define _use_X, which blindly without any checks says:
# "(do not) use this capability", (use_dbms_capability is an "inherited"
# type accessor)
#
# If _use_X is undef, _supports_X is then queried. This is a "simple" style
# accessor, which in turn calls _determine_supports_X, and stores the return
# in a special slot on the storage object, which is wiped every time a $dbh
# reconnection takes place (it is not guaranteed that upon reconnection we
# will get the same rdbms version). _determine_supports_X does not need to
# exist on a driver, as we ->can for it before calling.

my @capabilities = (qw/
  insert_returning
  insert_returning_bound

  multicolumn_in

  placeholders
  typeless_placeholders

  join_optimizer
/);

lib/DBIx/Class/Storage/DBI.pm  view on Meta::CPAN

=head1 SYNOPSIS

  my $schema = MySchema->connect('dbi:SQLite:my.db');

  $schema->storage->debug(1);

  my @stuff = $schema->storage->dbh_do(
    sub {
      my ($storage, $dbh, @args) = @_;
      $dbh->do("DROP TABLE authors");
    },
    @column_list
  );

  $schema->resultset('Book')->search({
     written_on => $schema->storage->datetime_parser->format_datetime(DateTime->now)
  });

=head1 DESCRIPTION

This class represents the connection to an RDBMS via L<DBI>.  See
L<DBIx::Class::Storage> for general information.  This pod only
documents DBI-specific methods and behaviors.

=head1 METHODS

=cut

sub new {
  my $new = shift->next::method(@_);

  $new->_sql_maker_opts({});
  $new->_dbh_details({});
  $new->{_in_do_block} = 0;

  # read below to see what this does
  $new->_arm_global_destructor;

  $new;
}

# This is hack to work around perl shooting stuff in random
# order on exit(). If we do not walk the remaining storage
# objects in an END block, there is a *small but real* chance
# of a fork()ed child to kill the parent's shared DBI handle,
# *before perl reaches the DESTROY in this package*
# Yes, it is ugly and effective.
# Additionally this registry is used by the CLONE method to
# make sure no handles are shared between threads
{
  my %seek_and_destroy;

  sub _arm_global_destructor {

    # quick "garbage collection" pass - prevents the registry
    # from slowly growing with a bunch of undef-valued keys
    defined $seek_and_destroy{$_} or delete $seek_and_destroy{$_}
      for keys %seek_and_destroy;

    weaken (
      $seek_and_destroy{ refaddr($_[0]) } = $_[0]
    );
  }

  END {
    local $?; # just in case the DBI destructor changes it somehow

    # destroy just the object if not native to this process
    $_->_verify_pid for (grep
      { defined $_ }
      values %seek_and_destroy
    );
  }

  sub CLONE {
    # As per DBI's recommendation, DBIC disconnects all handles as
    # soon as possible (DBIC will reconnect only on demand from within
    # the thread)
    my @instances = grep { defined $_ } values %seek_and_destroy;
    %seek_and_destroy = ();

    for (@instances) {
      $_->_dbh(undef);

      $_->transaction_depth(0);
      $_->savepoints([]);

      # properly renumber existing refs
      $_->_arm_global_destructor
    }
  }
}

sub DESTROY {
  return if &detected_reinvoked_destructor;

  $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
  # some databases spew warnings on implicit disconnect
  local $SIG{__WARN__} = sub {};
  $_[0]->_dbh(undef);

  # this op is necessary, since the very last perl runtime statement
  # triggers a global destruction shootout, and the $SIG localization
  # may very well be destroyed before perl actually gets to do the
  # $dbh undef
  1;
}

# handle pid changes correctly - do not destroy parent's connection
sub _verify_pid {

  my $pid = $_[0]->_conn_pid;

  if( defined $pid and $pid != $$ and my $dbh = $_[0]->_dbh ) {
    $dbh->{InactiveDestroy} = 1;
    $_[0]->_dbh(undef);
    $_[0]->transaction_depth(0);
    $_[0]->savepoints([]);
  }

lib/DBIx/Class/Storage/DBI.pm  view on Meta::CPAN

      or
    ! length( $requested_base_class )
  );

  my $old_class = ref( $self->sql_maker );

  # nothing to do!
  return if $old_class->isa( $requested_base_class );

  my $synthetic_class = "${old_class}__REBASED_ON__${requested_base_class}";

  {
    no strict 'refs';

    # skip if we already made that class
    unless( @{"${synthetic_class}::ISA"} ) {

      $self->ensure_class_loaded( $requested_base_class );

      for my $base (qw(
        DBIx::Class::SQLMaker::ClassicExtensions
        SQL::Abstract::Classic
      )) {

        $self->throw_exception(
          "The 'rebase_sqlmaker' target class '$requested_base_class' is not inheriting from '$base', this can not work"
        ) unless $requested_base_class->isa( $base );
      }

      $self->inject_base( $synthetic_class, $old_class, $requested_base_class );

      Class::C3->reinitialize
        if DBIx::Class::_ENV_::OLD_MRO;
    }
  }

  # force re-build on next access for this particular $storage instance
  $self->sql_maker_class( $synthetic_class );
  $self->_sql_maker( undef );
}

sub _connect {
  my $self = shift;

  my $info = $self->_dbi_connect_info;

  $self->throw_exception("You did not provide any connection_info")
    unless defined $info->[0];

  my ($old_connect_via, $dbh);

  local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL};

  # this odd anonymous coderef dereference is in fact really
  # necessary to avoid the unwanted effect described in perl5
  # RT#75792
  #
  # in addition the coderef itself can't reside inside the try{} block below
  # as it somehow triggers a leak under perl -d
  my $dbh_error_handler_installer = sub {
    weaken (my $weak_self = $_[0]);

    # the coderef is blessed so we can distinguish it from externally
    # supplied handles (which must be preserved)
    $_[1]->{HandleError} = bless sub {
      if ($weak_self) {
        $weak_self->throw_exception("DBI Exception: $_[0]");
      }
      else {
        # the handler may be invoked by something totally out of
        # the scope of DBIC
        DBIx::Class::Exception->throw("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]");
      }
    }, '__DBIC__DBH__ERROR__HANDLER__';
  };

  try {
    if(ref $info->[0] eq 'CODE') {
      $dbh = $info->[0]->();
    }
    else {
      require DBI;
      $dbh = DBI->connect(@$info);
    }

    die $DBI::errstr unless $dbh;

    die sprintf ("%s fresh DBI handle with a *false* 'Active' attribute. "
      . 'This handle is disconnected as far as DBIC is concerned, and we can '
      . 'not continue',
      ref $info->[0] eq 'CODE'
        ? "Connection coderef $info->[0] returned a"
        : 'DBI->connect($schema->storage->connect_info) resulted in a'
    ) unless $dbh->FETCH('Active');

    # sanity checks unless asked otherwise
    unless ($self->unsafe) {

      $self->throw_exception(
        'Refusing clobbering of {HandleError} installed on externally supplied '
       ."DBI handle $dbh. Either remove the handler or use the 'unsafe' attribute."
      ) if $dbh->{HandleError} and ref $dbh->{HandleError} ne '__DBIC__DBH__ERROR__HANDLER__';

      # Default via _default_dbi_connect_attributes is 1, hence it was an explicit
      # request, or an external handle. Complain and set anyway
      unless ($dbh->{RaiseError}) {
        carp( ref $info->[0] eq 'CODE'

          ? "The 'RaiseError' of the externally supplied DBI handle is set to false. "
           ."DBIx::Class will toggle it back to true, unless the 'unsafe' connect "
           .'attribute has been supplied'

          : 'RaiseError => 0 supplied in your connection_info, without an explicit '
           .'unsafe => 1. Toggling RaiseError back to true'
        );

        $dbh->{RaiseError} = 1;
      }

      $dbh_error_handler_installer->($self, $dbh);
    }