view release on metacpan or  search on metacpan

lib/Data/ObjectDriver/Driver/DBI.pm  view on Meta::CPAN

# $Id$

package Data::ObjectDriver::Driver::DBI;
use strict;
use warnings;

use base qw( Data::ObjectDriver Class::Accessor::Fast );

use DBI;
use Carp ();
use Data::ObjectDriver::Errors;
use Data::ObjectDriver::SQL;
use Data::ObjectDriver::Driver::DBD;
use Data::ObjectDriver::Iterator;
use Scalar::Util 'blessed';

my $ForkSafe = _is_fork_safe();
my %Handles;

sub _is_fork_safe {
    return if exists $ENV{DOD_FORK_SAFE} and !$ENV{DOD_FORK_SAFE};
    eval { require POSIX::AtFork; 1 } or return;
    eval { require Scalar::Util; Scalar::Util->import('weaken'); 1 } or return;
    return 1;
}

__PACKAGE__->mk_accessors(qw( dsn username password connect_options get_dbh dbd prefix reuse_dbh force_no_prepared_cache));


sub init {
    my $driver = shift;
    my %param = @_;
    for my $key (keys %param) {
        $driver->$key($param{$key});
    }
    if(!exists $param{dbd}) {
        ## Create a DSN-specific driver (e.g. "mysql").
        my $type;
        if (my $dsn = $driver->dsn) {
            ($type) = $dsn =~ /^dbi:(\w*)/i;
        } elsif (my $dbh = $driver->dbh) {
            $type = $dbh->{Driver}{Name};
        } elsif (my $getter = $driver->get_dbh) {
## Ugly. Shouldn't have to connect just to get the driver name.
            my $dbh = $getter->();
            $type = $dbh->{Driver}{Name};
        }
        $driver->dbd(Data::ObjectDriver::Driver::DBD->new($type));
    }

    if ($ForkSafe) {
        # Purge cached handles
        weaken(my $driver_weaken = $driver);
        POSIX::AtFork->add_to_child(sub {
            return unless $driver_weaken;
            $driver_weaken->{dbh} = undef;
            %Handles = ();
        });
    }

    $driver;
}

sub generate_pk {
    my $driver = shift;
    if (my $generator = $driver->pk_generator) {
        return $generator->(@_);
    }
}

# Some versions of SQLite require the undefing to finalise properly
sub _close_sth {
    my $sth = shift;
    $sth->finish;
    undef $sth;
}

# Some versions of SQLite have problems with prepared caching due to finalisation order
sub _prepare_cached {
    my $driver = shift;
    my $dbh    = shift;
    my $sql    = shift;
    return ($driver->dbd->can_prepare_cached_statements)? $dbh->prepare_cached($sql) : $dbh->prepare($sql);
}

sub init_db {
    my $driver = shift;
    my $dbh;
    if ($driver->reuse_dbh) {
        $dbh = $Handles{$driver->dsn};
    }
    unless ($dbh) {
        eval {
            $dbh = DBI->connect($driver->dsn, $driver->username, $driver->password,
                { RaiseError => 1, PrintError => 0, AutoCommit => 1,
                ( $ForkSafe ? ( AutoInactiveDestroy => 1 ) : () ),
                %{$driver->connect_options || {}} })
                or Carp::croak("Connection error: " . $DBI::errstr);
        };
        if ($@) {
            Carp::croak($@);
        }
    }
    if ($driver->reuse_dbh) {
        $Handles{$driver->dsn} = $dbh;
    }
    $driver->dbd->init_dbh($dbh);
    $driver->{__dbh_init_by_driver} = 1;
    return $dbh;
}

sub dbh {
    my $driver = shift;
    if (@_) {
        my $dbh = $driver->{dbh} = shift;
        if (!$dbh && $driver->reuse_dbh) {