view release on metacpan or  search on metacpan

lib/Activator/DB.pm  view on Meta::CPAN

package Activator::DB;
use strict;
use warnings;

use Activator::Log qw( :levels );
use Activator::Registry;
use DBI;
use Exception::Class::DBI;
use Exception::Class::TryCatch;
use Data::Dumper;
use Time::HiRes qw( gettimeofday tv_interval );
use Scalar::Util;
use base 'Class::StrongSingleton';

# constructor: implements singleton
sub new {
    my ( $pkg, $conn_alias ) = @_;

    my $self = bless( {}, $pkg);

    $self->_init_StrongSingleton();

    return $self;
}

# connect to a db alias
# initializes singleton object returned from new()
# Args:
#   $conn_alias => the alias to use as configured in the registry
sub connect {
    my ( $pkg, $conn_alias ) = @_;
    my $self = &new( @_ );

    $conn_alias ||= 'default';

    # first call
    # TODO: also look for a some sighup to reload this config
    if( !keys( %{ $self->{config} } ) ) {
	$self->_init();
    }

    # set the current alias for the object
    if ( $conn_alias !~ /^def(ault)?$/ ) {
	$self->{cur_alias} = $conn_alias;
    }
    else {
	$self->{last_alias} = $self->{cur_alias};
	$self->{cur_alias} = $self->{default}->{connection};
    }

    my $conn;
    try eval {
	$conn = $self->_get_cur_conn();
    };
    if ( catch my $e ) {
	$self->{cur_alias} = $self->{last_alias};
	$e->rethrow;
    }


    # est. the actual connection if it's not set
    if ( !$conn->{dbh} ) {
	try eval {
	    $self->_debug_connection( 2, "Connecting to alias $self->{cur_alias}" );
	    $self->_debug_connection( 2, 'Connect Parameters:');
	    $self->_debug_connection( 2, "   dsn  => $conn->{dsn}");
	    $self->_debug_connection( 2, "   user => $conn->{user}");
	    $self->_debug_connection( 2, '   pass => ' . ( $conn->{pass} || ''));
	    $self->_debug_connection( 2, Data::Dumper->Dump( [ $conn->{attr} ], [ '  attr' ] ) );

	    try eval {
		$conn->{dbh} = DBI->connect( $conn->{dsn},
					     $conn->{user} || '',
					     $conn->{pass} || '',
					     $conn->{attr}
					   );
	    };

	    if ( catch my $e ) {

lib/Activator/DB.pm  view on Meta::CPAN

#  Test a database handle and attempt to reconnect if it is done
#
#  Args:
#    $conn_alias => connection alias to check
#
#  Throws:
#     connection.failure - failure to ping connection
#
sub _ping {
    my ( $self ) = @_;
    my $conn = $self->_get_cur_conn();
    my $dbh = $conn->{dbh};
    local $dbh->{RaiseError} = 1;
    my $reconn_att =
      $conn->{config}->{reconn_att} ||
	$self->{config}->{reconn_att};
    my $reconn_sleep =
      $conn->{config}->{reconn_sleep} ||
	$self->{config}->{reconn_sleep};
    while ( $reconn_att > 0 ) {
	try eval { $dbh->ping(); };
	if ( catch my $e ) {
	    $reconn_att--;
	    sleep $reconn_sleep;
	    $reconn_sleep *= 2;
	} else {
	    return 1;
	}
    }
    ERROR( "connection to $conn->{alias} appears to be dead" );
    Activator::Exception::DB->throw( 'ping', 'failure' );
}

# _get_cur_conn
#
# return the internal connection hash for the current connection alias
sub _get_cur_conn {
    my ( $self ) = @_;

    if ( exists( $self->{connections}->{  $self->{cur_alias} } ) ) {
	my $conn = $self->{connections}->{  $self->{cur_alias} };

#	# set the log level to this connection
#	LEVEL( $conn->{config}->{debug}
#				? $Log::Log4perl::$self->_debug
#				: $Log::Log4perl::WARN );
	return $conn;
    }
    Activator::Exception::DB->throw('alias', 'invalid', $self->{cur_alias} )
}

# explode args for a db query sub
sub _explode {
    my ( $pkg, $bindref, $args ) = @_;

    my $bind = $bindref || [];
    my $self = $pkg;
    my $connect_to = $args->{connect};

     # handle static calls
    if ( !( Scalar::Util::blessed($self) && $self->isa( 'Activator::DB') ) ) {
	if ( $connect_to ) {
	    $self = Activator::DB->connect( $connect_to );
	}
	else {
	    Activator::Exception::DB->throw( 'connect', 'missing');
	}
    }

    # static or OO, respect the connect
    if ( $connect_to ) {
	$self->{cur_alias} = $connect_to;
    }

    # This next line insures that $self refers to the singleton object
    $self = $self->connect( $self->{cur_alias} );
    my $conn = $self->_get_cur_conn()
      or Activator::Exception::DB->throw( 'connection',
					  'failure',
					  "_explode couldn't get connection for alias '$self->{cur_alias}'");

    my $attr        = $args->{attr} || {};

    return ( $self, $bind, $attr );
}

# This can never die, so we jump through hoops to return some valid scalar.
#     * replace undef values with NULL, since this is how dbi will do it
#     * If $bind is of wrong type, don't do substitutions.
#     * shift @vals to handle the case of '?' in the bind values
#     * @vals? in the regexp is to handle fewer args on the right than the left
# TODO: support attrs in debug
sub _get_sql {
    my ( $pkg, $sql, $bind ) = @_;
    $sql  ||= '';
    $bind ||= [];

    if ( ref( $bind ) eq 'ARRAY' ) {
	my @vals = @$bind;
 	map {
 	    if ( !defined($_) ) {
 		$_ = 'NULL';
 	    }
 	    else {
 		$_ =  "'$_'";
 	    } } @vals;
 	$sql =~ s/\?/@vals? (shift @vals) : '?'/egos;

	return $sql;
    }
    else {
	if ( $bind ) {
	    return "[SQL] ${sql} [BIND VARS] $bind";
	}
	return $sql;
    }
}

# returns sth, unless you want the result of the execute,
sub _get_sth {
    my ( $self, $sql, $bind, $attr, $want_exec_result ) = @_;