File Coverage

blib/lib/Scope/Container/DBI.pm

Criterion	Covered	Total	%
statement	113	126	89.6
branch	44	60	73.3
condition	17	40	42.5
subroutine	18	18	100.0
pod	1	2	50.0
total	193	246	78.4

package Scope::Container::DBI;

use strict;
use warnings;
use Scope::Container;
use Log::Minimal;
use List::Util qw/shuffle/;
use Data::Dumper;
use Try::Tiny;
use Time::HiRes qw//;
use Module::Load qw/load/;
use Carp;
use DBI 1.615;

our $VERSION = '0.09';
our $DBI_CLASS = 'DBI';

sub connect {
    my $class = shift;

    if ( @_ && (ref $_[0] || '' eq 'ARRAY') ) {
        my @dsn = @_;
        my $dbi;
        my $dsn_key = _build_dsn_key(@dsn);
        my $dbh = _lookup_cache($dsn_key);
        return $dbh if $dbh;

        for my $s_dsn ( shuffle(@dsn) ) {
            eval {
                ($dbh, $dbi) = $class->connect(@$s_dsn);
            };
            infof("Connection failed: " . $@) if $@;
            last if ( $dbh );
        }

        if ( $dbh ) {
            _save_cache($dsn_key, $dbi);
            return wantarray ? ( $dbh, $dbi) : $dbh;
        }

        croak("couldn't connect all DB, " .
            join(",", map { $_->[0] } @dsn));
    }

    my @dsn = @_;
    my $dsn_key = _build_dsn_key(\@dsn);
    my $cached_dbh = _lookup_cache($dsn_key);
    return $cached_dbh if $cached_dbh;

    my ($dsn, $user, $pass, $attr) = @dsn;
    $attr ||= {};
    $attr->{AutoInactiveDestroy} = 1;
    my $retry = exists $attr->{ScopeContainerConnectRetry} ? delete $attr->{ScopeContainerConnectRetry} : 1;
    my $sleep = delete $attr->{ScopeContainerConnectRetrySleep};
    $sleep = $sleep / 1000 if $sleep;

    if ( ! is_class_loaded($DBI_CLASS) ) {
        load $DBI_CLASS;
    }
    my $lasterrstr;
    my $dbh = do {
        my $connect;
        for ( 1..$retry ) {
            try {
                if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
                    local $DBI::connect_via = 'connect'; # Disable Apache::DBI.
                    $connect = $DBI_CLASS->connect( $dsn, $user, $pass, $attr );
                } else {
                    $connect = $DBI_CLASS->connect( $dsn, $user, $pass, $attr );
                }
                die $DBI::errstr."\n" unless $connect;
            }
            catch {
                $lasterrstr = $_;
            };
            last if $connect;
            Time::HiRes::sleep($sleep) if $sleep && $retry != $_;
        }
        $connect;
    };
    croak($lasterrstr) if !$dbh;

    my $dbi = {
        dbh => $dbh,
        pid => $$,
    };
    $dbi->{tid} = threads->tid if $INC{'threads.pm'};

    _save_cache($dsn_key, $dbi);
    return wantarray ? ( $dbh, $dbi ) : $dbh;
}


sub _build_dsn_key {
    my @dsn = @_;
    local $Data::Dumper::Terse = 1;
    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Sortkeys = 1;
    my $key = Data::Dumper::Dumper(\@dsn);
    "sc:dbix:".$key;
}

sub _lookup_cache {
    my $key = shift;
    return unless in_scope_container();
    my $dbi = scope_container($key);
    return if !$dbi;

    my $dbh = $dbi->{dbh};
    if ( defined $dbi->{tid} && $dbi->{tid} != threads->tid ) {
        return;
    }
    if ( $dbi->{pid} != $$ ) {
        $dbh->STORE(InactiveDestroy => 1);
        return;
    }
    return $dbh if $dbh->FETCH('Active') && $dbh->ping;
    return;
}

sub _save_cache {
    my $key = shift;
    return unless in_scope_container();
    scope_container($key, shift);
}

# stolen from Mouse::PurePerl
sub is_class_loaded {
    my $class = shift;

    return 0 if ref($class) || !defined($class) || !length($class);

    # walk the symbol table tree to avoid autovififying
    # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar::

    my $pack = \%::;

    foreach my $part (split('::', $class)) {
        $part .= '::';
        return 0 if !exists $pack->{$part};

        my $entry = \$pack->{$part};
        return 0 if ref($entry) ne 'GLOB';
        $pack = *{$entry}{HASH};
    }

    return 0 if !%{$pack};

    # check for $VERSION or @ISA
    return 1 if exists $pack->{VERSION}
             && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
    return 1 if exists $pack->{ISA}
             && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;

    # check for any method
    foreach my $name( keys %{$pack} ) {
        my $entry = \$pack->{$name};
        return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
    }

    # fail
    return 0;
}


1;
__END__