Fey::DBIManager::Source - Wraps a single DBI handle

  my $source = Fey::DBIManager::Source->new( dbh => $dbh );

  my $dbh = $source->dbh();

  The Artistic License 2.0 (GPL Compatible)

package Fey::DBIManager::Source;
BEGIN {
  $Fey::DBIManager::Source::VERSION = '0.16';
}

use strict;
use warnings;
use namespace::autoclean;

use DBI;
use Fey::Exceptions qw( param_error );

use Moose;
use MooseX::SemiAffordanceAccessor;
use MooseX::StrictConstructor;

has 'name' => (
    is      => 'ro',
    isa     => 'Str',
    default => 'default',
);

has 'dbh' => (
    is         => 'rw',
    isa        => 'DBI::db',
    reader     => '_dbh',
    writer     => '_set_dbh',
    clearer    => '_unset_dbh',
    predicate  => '_has_dbh',
    lazy_build => 1,
);

after '_unset_dbh' => sub { $_[0]->_clear_allows_nested_transactions() };

has 'dsn' => (
    is        => 'rw',
    isa       => 'Str',
    predicate => '_has_dsn',
    writer    => '_set_dsn',
    required  => 1,
);

has 'username' => (
    is      => 'ro',
    isa     => 'Str',
    default => '',
);

has 'password' => (
    is      => 'ro',
    isa     => 'Str',
    default => '',
);

has 'attributes' => (
    is      => 'rw',
    isa     => 'HashRef',
    writer  => '_set_attributes',
    default => sub { {} },
);

has 'post_connect' => (
    is  => 'ro',
    isa => 'CodeRef',
);

has 'auto_refresh' => (
    is      => 'ro',
    isa     => 'Bool',
    default => 1,
);

has 'allows_nested_transactions' => (
    is         => 'ro',
    isa        => 'Bool',
    lazy_build => 1,
    clearer    => '_clear_allows_nested_transactions',
);

has '_threaded' => (
    is         => 'ro',
    isa        => 'Bool',
    lazy_build => 1,
    init_arg   => undef,
);

has '_pid' => (
    is       => 'rw',
    isa      => 'Num',
    init_arg => undef,
);

has '_tid' => (
    is       => 'rw',
    isa      => 'Num',
    init_arg => undef,
);

has 'ping_interval' => (
    is      => 'ro',
    isa     => 'Maybe[Int]',
    default => 60,
);

has '_last_ping' => (
    is       => 'rw',
    isa      => 'Int',
    default  => 0,
    clearer  => '_clear_last_ping',
    lazy     => 1,
    init_arg => undef,
);

sub BUILD {
    my $self   = shift;
    my $params = shift;

    $self->_set_attributes(
        {
            %{ $self->attributes() },
            $self->_required_dbh_attributes(),
        }
    );

    if ( $self->_has_dbh() ) {
        $self->_set_pid_tid();
        $self->_apply_required_dbh_attributes();
    }

    return $self;
}

sub clone {
    my $self = shift;

    my %p = map { $_ => $self->$_() }
        grep { defined $self->$_() }
        qw( dsn username password attributes post_connect auto_refresh );

    return ( ref $self )->new(
        name => 'Clone of ' . $self->name(),
        %p,
        @_,
    );
}

sub _required_dbh_attributes {
    return (
        AutoCommit         => 1,
        RaiseError         => 1,
        PrintError         => 0,
        PrintWarn          => 1,
        ShowErrorStatement => 1,
    );
}

sub _apply_required_dbh_attributes {
    my $self = shift;

    my %attr = $self->_required_dbh_attributes();

    for my $k ( sort keys %attr ) {
        $self->dbh()->{$k} = $attr{$k};
    }
}

sub dbh {
    my $self = shift;

    $self->_ensure_fresh_dbh() if $self->auto_refresh();

    return $self->_dbh();
}

sub _build_dbh {
    my $self = shift;

    my $dbh = DBI->connect(
        $self->dsn(),      $self->username(),
        $self->password(), $self->attributes()
    );

    $self->_set_pid_tid();

    if ( my $pc = $self->post_connect() ) {
        $pc->($dbh);
    }

    $self->_set_dbh($dbh);

    return $self->_dbh();
}

sub _build_allows_nested_transactions {
    my $self = shift;

    my $dbh = $self->dbh();

    my $allows_nested = eval {

        # This error comes from DBI in its default implementation
        # of begin_work(). There didn't seem to be a way to shut
        # this off (setting PrintWarn to false does not do it, and
        # setting Warn to false does not stop it for all drivers,
        # either). Hopefully the message text won't change.
        #
        # The variant is for DBD::Mock, which has a slightly
        # different version of the text.
        local $SIG{__WARN__} = sub {
            warn @_
                unless $_[0] =~ /Already (?:with)?in a transaction/i
                    || $_[0] =~ /rollback ineffective/;
        };

        $dbh->begin_work();
        $dbh->begin_work();
        $dbh->rollback();
        $dbh->rollback();
        1;
    };

    if ($@) {
        $dbh->rollback() unless $dbh->{AutoCommit};
    }

    return $allows_nested;
}

sub _build__threaded {
    return threads->can('tid') ? 1 : 0;
}

sub _set_pid_tid {
    my $self = shift;

    $self->_set_pid($$);
    $self->_set_tid( threads->tid() ) if $self->_threaded();
}

# The logic in this method is largely borrowed from
# DBIx::Class::Storage::DBI.
sub _ensure_fresh_dbh {
    my $self = shift;

    my $dbh = $self->_dbh();
    if ( $self->_pid() != $$ ) {
        $dbh->{InactiveDestroy} = 1;
        $self->_unset_dbh();
        undef $dbh;
    }

    if (   $self->_threaded()
        && $self->_tid() != threads->tid() ) {
        $self->_unset_dbh();
        undef $dbh;
    }

    if ( $dbh && !( $dbh->{Active} && $self->_ping_dbh() ) ) {
        $dbh->disconnect();
        $self->_unset_dbh();
    }

    $self->_build_dbh() unless $self->_has_dbh();
}

sub _ping_dbh {
    my $self = shift;

    my $now  = time();

    return 1 unless defined $self->ping_interval();
    return 1 if ( $now - $self->_last_ping() ) < $self->ping_interval();

    if ( $self->_dbh()->ping() ) {
        $self->_set_last_ping($now);
        return 1;
    }
    else {
        $self->_clear_last_ping();
        return 0;
    }
}

__PACKAGE__->meta()->make_immutable();

1;

# ABSTRACT: Wraps a single DBI handle

__END__