File Coverage

blib/lib/DBIx/Connector.pm

Criterion	Covered	Total	%
statement	181	181	100.0
branch	90	94	95.7
condition	28	39	71.7
subroutine	29	29	100.0
pod	14	14	100.0
total	342	357	95.8

use 5.008001; use strict; use warnings;

package DBIx::Connector;

use DBI '1.605';
use DBIx::Connector::Driver;

our $VERSION = '0.57';

sub new {
    my $class = shift;
    my @args = @_;
    bless {
        _args      => sub { @args },
        _svp_depth => 0,
        _mode      => 'no_ping',
        _dond      => 1,
    } => $class;
}

sub DESTROY { $_[0]->disconnect if $_[0]->{_dond} }

sub _connect {
    my $self = shift;
    my @args = $self->{_args}->();
    my $dbh = do {
        if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
            local $DBI::connect_via = 'connect'; # Disable Apache::DBI.
            DBI->connect( @args );
        } else {
            DBI->connect( @args );
        }
    } or return undef;

    # Modify default values.
    $dbh->STORE(AutoInactiveDestroy => 1) if DBI->VERSION > 1.613 && (
        @args < 4 || !exists $args[3]->{AutoInactiveDestroy}
    );

    $dbh->STORE(RaiseError => 1) if @args < 4 || (
        !exists $args[3]->{RaiseError} && !exists $args[3]->{HandleError}
    );

    # Where are we?
    $self->{_pid} = $$;
    $self->{_tid} = threads->tid if $INC{'threads.pm'};
    $self->{_dbh} = $dbh;

    $self->{driver_name} ||= $dbh->{Driver}{Name};

    # Set up the driver and go!
    return $self->driver->_connect($dbh, @args);
}

sub dsn { ( $_[0]{_args}->() )[0] }

sub driver_name {
    my $self = shift;
    $self->{driver_name} ||= ( DBI->parse_dsn( $self->dsn ) )[1];
}

sub driver {
    my $self = shift;
    $self->{driver} ||= DBIx::Connector::Driver->new( $self->{driver_name} || $self->driver_name );
}

sub connect {
    my $self = shift->new(@_);
    $self->{_dond} = 0;
    $self->dbh;
}

sub dbh {
    my $self = shift;
    my $dbh = $self->_seems_connected or return $self->_connect;
    return $dbh if $self->{_in_run};
    return $self->connected ? $dbh : $self->_connect;
}

# Just like dbh(), except it doesn't ping the server.
sub _dbh {
    my $self = shift;
    $self->_seems_connected || $self->_connect;
}

sub connected {
    my $self = shift;
    return unless $self->_seems_connected;
    my $dbh = $self->{_dbh} or return;
    return $self->driver->ping($dbh);
}

sub mode {
    my $self = shift;
    return $self->{_mode} unless @_;
    require Carp && Carp::croak(qq{Invalid mode: "$_[0]"})
        unless $_[0] =~ /^(?:fixup|(?:no_)?ping)$/;
    $self->{_mode} = shift;
}

sub disconnect_on_destroy {
    my $self = shift;
    return $self->{_dond} unless @_;
    $self->{_dond} = !!shift;
}

sub in_txn {
    my $dbh = shift->{_dbh} or return;
    return !$dbh->FETCH('AutoCommit');
}

# returns true if there is a database handle and the PID and TID have not
# changed and the handle's Active attribute is true.
sub _seems_connected {
    my $self = shift;
    my $dbh = $self->{_dbh} or return;
    if ( defined $self->{_tid} && $self->{_tid} != threads->tid ) {
        return;
    } elsif ( $self->{_pid} != $$ ) {
        # We've forked, so prevent the parent process handle from touching the
        # DB on DESTROY. Here in the child process, that could really screw
        # things up. This is superfluous when AutoInactiveDestroy is set, but
        # harmless. It's better to be proactive anyway.
        $dbh->STORE(InactiveDestroy => 1);
        return;
    }
    # Use FETCH() to avoid death when called from during global destruction.
    return $dbh->FETCH('Active') ? $dbh : undef;
}

sub disconnect {
    my $self = shift;
    if (my $dbh = $self->{_dbh}) {
        # Some databases need this to stop spewing warnings, according to
        # DBIx::Class::Storage::DBI. Probably Sybase, as the code was added
        # when Sybase ASA and SQLAnywhere support were added to DBIx::Class.
        # If that ever becomes an issue for us, add a _disconnect to the
        # Driver class that does it, don't do it here.
        # $dbh->STORE(CachedKids => {});
        $dbh->disconnect;
        $self->{_dbh} = undef;
    }
    return $self;
}

sub run {
    my $self = shift;
    my $mode = ref $_[0] eq 'CODE' ? $self->{_mode} : shift;
    local $self->{_mode} = $mode;
    return $self->_fixup_run(@_) if $mode eq 'fixup';
    return $self->_run(@_);
  }

sub _run {
    my ($self, $code) = @_;
    my $dbh = $self->{_mode} eq 'ping' ? $self->dbh : $self->_dbh;
    local $self->{_in_run} = 1;
    return _exec( $dbh, $code, wantarray );
}

sub _fixup_run {
    my ($self, $code) = @_;
    my $dbh  = $self->_dbh;

    my $wantarray = wantarray;
    return _exec( $dbh, $code, $wantarray )
        if $self->{_in_run} || !$dbh->FETCH('AutoCommit');

    local $self->{_in_run} = 1;
    my ($err, @ret);
    TRY: {
        local $@;
        @ret = eval { _exec( $dbh, $code, $wantarray ) };
        $err = $@;
    }

    if ($err) {
        die $err if $self->connected;
        # Not connected. Try again.
        return _exec( $self->_connect, $code, $wantarray, @_ );
    }

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

sub txn {
    my $self = shift;
    my $mode = ref $_[0] eq 'CODE' ? $self->{_mode} : shift;
    local $self->{_mode} = $mode;
    return $self->_txn_fixup_run(@_) if $mode eq 'fixup';
    return $self->_txn_run(@_);
}

sub _txn_run {
    my ($self, $code) = @_;
    my $driver = $self->driver;
    my $wantarray = wantarray;
    my $dbh = $self->{_mode} eq 'ping' ? $self->dbh : $self->_dbh;

    unless ($dbh->FETCH('AutoCommit')) {
        local $self->{_in_run}  = 1;
        return _exec( $dbh, $code, $wantarray );
    }

    my ($err, @ret);
    TRY: {
        local $@;
        eval {
            local $self->{_in_run}  = 1;
            $driver->begin_work($dbh);
            @ret = _exec( $dbh, $code, $wantarray );
            $driver->commit($dbh);
        };
        $err = $@;
    }

    if ($err) {
        $err = $driver->_rollback($dbh, $err);
        die $err;
    }

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

sub _txn_fixup_run {
    my ($self, $code) = @_;
    my $dbh    = $self->_dbh;
    my $driver = $self->driver;

    my $wantarray = wantarray;
    local $self->{_in_run}  = 1;

    return _exec( $dbh, $code, $wantarray ) unless $dbh->FETCH('AutoCommit');

    my ($err, @ret);
    TRY: {
        local $@;
        eval {
            $driver->begin_work($dbh);
            @ret = _exec( $dbh, $code, $wantarray );
            $driver->commit($dbh);
        };
        $err = $@;
    }

    if ($err) {
        if ($self->connected) {
            $err = $driver->_rollback($dbh, $err);
            die $err;
        }

        # Not connected. Try again.
        $dbh = $self->_connect;
        TRY: {
            local $@;
            eval {
                $driver->begin_work($dbh);
                @ret = _exec( $dbh, $code, $wantarray );
                $driver->commit($dbh);
            };
            $err = $@;
        }
        if ($err) {
            $err = $driver->_rollback($dbh, $err);
            die $err;
        }
    }

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

sub svp {
    my $self = shift;
    my $dbh  = $self->{_dbh};

    # Gotta have a transaction.
    return $self->txn( @_ ) if !$dbh || $dbh->FETCH('AutoCommit');

    my $mode = ref $_[0] eq 'CODE' ? $self->{_mode} : shift;
    local $self->{_mode} = $mode;
    my $code = shift;

    my ($err, @ret);
    my $wantarray = wantarray;
    my $driver    = $self->driver;
    my $name      = "savepoint_$self->{_svp_depth}";
    ++$self->{_svp_depth};

    TRY: {
        local $@;
        eval {
            $driver->savepoint($dbh, $name);
            @ret = _exec( $dbh, $code, $wantarray );
            $driver->release($dbh, $name);
        };
        $err = $@;
    }
    --$self->{_svp_depth};

    if ($err) {
        # If we died, there is nothing to be done.
        if ($self->connected) {
            $err = $driver->_rollback_and_release($dbh, $name, $err);
        }
        die $err;
    }

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

sub _exec {
    my ($dbh, $code, $wantarray) = @_;
    local $_ = $dbh or return;
    # Block prevents exiting via next or last, otherwise no commit/rollback.
    NOEXIT: {
        return $wantarray ? $code->($dbh) : scalar $code->($dbh)
            if defined $wantarray;
        return $code->($dbh);
    }
    return;
}

1;

__END__