File Coverage

blib/lib/Database/ManagedHandle.pm

Criterion	Covered	Total	%
statement	83	92	90.2
branch	18	30	60.0
condition	1	3	33.3
subroutine	14	14	100.0
pod	1	2	50.0
total	117	141	82.9

package Database::ManagedHandle;
## no critic (ControlStructures::ProhibitPostfixControls)

use strict;
use warnings;

# ABSTRACT: Manage database handles safely for long running processes

our $VERSION = '0.003'; # VERSION: generated by DZP::OurPkgVersion

use Carp         qw( croak );
use Module::Load qw( load );
use English      qw( -no_match_vars );
use Storable     qw( dclone );

use Moo;
with 'MooX::Singleton';

use DBI;
use Log::Any ();

has _log => (
    is      => 'ro',
    default => sub {
        Log::Any->get_logger;
    },
);

has _handles => ( is => 'rw', );
has _config  => ( is => 'rw', );

sub BUILD {
    my ($self) = @_;
    my $cfg_module = 'Database::ManagedHandleConfig';
    if ( $ENV{DATABASE_MANAGED_HANDLE_CONFIG} ) {
        ($cfg_module) = $ENV{DATABASE_MANAGED_HANDLE_CONFIG} =~ m/^([[:alnum:]:_]{1,})$/msx;
    }
    local $EVAL_ERROR = undef;    # protect existing $@ ($EVAL_ERROR)
    my $r = eval {
        load $cfg_module;
        1;
    };
    if ( $EVAL_ERROR || !$r ) {
        croak 'Cannot load module ', $cfg_module, '. Error: ', $EVAL_ERROR;
    }

    # Make a clone of the configuration for safety.
    # Without dangling references, created object will be collected.
    my $config = dclone( $cfg_module->new()->config() );

    $self->_check_config_is_valid($config);
    $self->_handles( { map { $_ => undef } keys %{ $config->{'databases'} } } );
    $self->_config($config);
    return;
}

sub _check_config_is_valid {
    my ( $self, $config ) = @_;
    $self->_log->debugf( '_check_config_is_valid(%s)', $config );
    croak 'Config missing item \'default\''   unless exists $config->{'default'};
    croak 'Config missing item \'databases\'' unless exists $config->{'databases'};
    my $default = $config->{'default'};
    croak 'Config missing default database' unless exists $config->{'databases'}->{$default};
    foreach my $db_name ( keys %{ $config->{'databases'} } ) {
        my $db = $config->{'databases'}->{$db_name};
        foreach (qw( dsn username password attr )) {
            croak "Config missing item '$_' in database '$db_name'" unless exists $db->{$_};
        }
    }
    return 1;
}

sub dbh {
    my ( $self, $name ) = @_;
    $self->_log->debugf( 'dbh(%s)', $name );

    my $handles = $self->_handles;
    my $config  = $self->_config;
    $name = $config->{'default'} unless ($name);

    croak 'No database with name ' . $name . ' in config'
      unless exists $config->{'databases'}->{$name};
    my $dbh = $handles->{$name};

    if ( !$self->_verify_connection_working($dbh) ) {
        $self->_log->infof( 'Connection not working for dbh %s, db %s. Connecting...', $dbh, $name );
        $dbh = $self->_create_dbh( $config->{'databases'}->{$name} );
        $handles->{$name} = $dbh;
    }

    return $dbh;
}

sub _create_dbh {
    my ( $self, $cfg ) = @_;
    $self->_log->debugf( 'Database::ManagedHandle::_create_dbh(%s)', $cfg );
    $self->_log->debugf( 'Database::ManagedHandle::_create_dbh): Create and connect database handle for dsn \'%s\'',
        $cfg->{'dsn'} );
    my $dbh = DBI->connect( $cfg->{'dsn'}, $cfg->{'username'}, $cfg->{'password'}, $cfg->{'attr'}, );
    if ( !defined $dbh ) {
        my $err = 'Could not open database. Error: %s';
        croak sprintf $err, $DBI::errstr;    ## no critic (Variables::ProhibitPackageVars)
    }
    return $dbh;
}

# This is partly borrowed from Dancer::Plugin::Database::Core and modified
# Check the connection is alive
sub _verify_connection_working {
    my ( $self, $dbh ) = @_;
    $self->_log->debugf( 'Verify connection working for handle \'%s\'', $dbh );

    # If dbh is undef, obviously there is no connection.
    return if ( !defined $dbh );

    if ( $dbh->{Active} ) {
        local $EVAL_ERROR = undef;    # protect existing $@ ($EVAL_ERROR)
        my $result = eval { $dbh->ping };
        return if $EVAL_ERROR;
        if ( int $result ) {

            # DB driver itself claims all is OK, trust it:
            return 1;
        }
        else {
            # It was "0 but true", meaning the default DBI ping implementation.
            # Implement our own basic check, by performing a real simple query.
            local $EVAL_ERROR = undef;    # protect existing $@ ($EVAL_ERROR)
            my $r = eval {

                # Returns the number of rows affected or undef on error.
                # A return value of -1 means the number of rows is not known,
                # not applicable, or not available.
                # https://metacpan.org/pod/DBI#do
                #     ($rows == 0) ? "0E0" : $rows; # always return true if no error
                # Will return "0E0"
                $dbh->do('SELECT 1');

                # The return value from eval will be the value of the last statement!
            };
            return if $EVAL_ERROR;
            return $r;
        }
    }
    else {
        return;
    }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Database::ManagedHandle - Manage database handles safely for long running processes

=head1 VERSION

version 0.003

=head1 SYNOPSIS

    # Create a class file from which the configuration can be read:
    package Database::ManagedHandleConfig;
    use Moo;
    has config => (
        is => 'ro',
        default => sub {
            return {
                default => q{db1},
                databases => {
                    db1 => {
                        dsn => "dbi:SQLite:uri=file:/tmp/first_db.sq3?mode=rwc",
                        username => undef,
                        password => undef,
                        attr => {},
                    },
                    db2 => {
                        dsn => 'dbi:Pg:dbname=db;host=go;port=5432;application_name=MyApp',
                        username => 'user',
                        password => 'pass',
                        attr => { ReadOnly => 0, AutoCommit => 0, PrintError => 0 },
                    },
                },
            };
        },
    );
    1;

    # In your program code:
    use Database::ManagedHandle;
    my $mh1 = Database::ManagedHandle->instance;
    my $dbh1 = $mh1->dbh();
    my $ary_ref = $dbh1->selectall_arrayref( 'SELECT current_timestamp()' );

    # Another example:
    Database::ManagedHandle->instance()->dbh('db2')->do( 'INSERT INTO t VALUES(1,2,3)' );

=head1 DESCRIPTION

Database::ManagedHandle is built for those long running web services or scripts
which can lose a database connection due to network issues, database being updated,
database itself closing unused connections after an idle period
or any other reason.

Database::ManagedHandle uses L<Moo> and specifically the L<MooX::Singleton> role to become
a L<Singleton|https://en.wikipedia.org/wiki/Singleton_pattern>.
This ensures that there is always only one instance of the class
in the entire running program. This in turn means that the program needs
only one database handle and it is accessible from any part of the code.

Database::ManagedHandle opens and reopens database handles when required.
It can house several handles. If there is more than one, then one handle
needs to be defined as the default.

When the program first requests a database handle,
either a named handle or the default,
Database::ManagedHandle opens the database connection and
passes the opened handle to the program.
After using the handle, the program does not need to worry about it.
It can safely let the variable fall out of scope.

During subsequent calls for the handle, Database::ManagedHandle
first ensures that the connection is still alive.
If not, it will establish the handle again.

Do not keep a database handle around.
Only use the same handle for one operation, then purposefully undef it or let it
drop out of scope.
When you need it again, get it from Database::ManagedHandle.

=head2 Configuration

Database::ManagedHandle reads its configuration from
a class. By default, the class name is C<Database::ManagedHandleConfig>.
Alternatively, set environment variable B<DATABASE_MANAGED_HANDLE_CONFIG>, e.g.
C<DATABASE_MANAGED_HANDLE_CONFIG=MyHandles>.

The configuration class must have two methods: C<new()> and C<config()>.
Neither takes any arguments. C<config()> returns a hash which has
the required information. See L</SYNOPSIS> for an example of how
to do this as a L<Moo> class.

=head2 Logging

Database::ManagedHandle uses the excellent L<Log::Any> to produce logging messages.

The easiest way to get the logging messages printed is to add the following line
in the preamble of your program:

    use Log::Any::Adapter ('Stdout', log_level => 'debug' );

Alternative, you can do this on the command line:

    perl '-MLog::Any::Adapter(Stdout, log_level=>trace)'

=for Pod::Coverage BUILD

=for stopwords dbh

=head1 METHODS

=head2 dbh

Get the default database handle.

    my $dbh = Database::ManagedHandle->instance()->dbh();

Get a database handle by its name.

    my $mh = Database::ManagedHandle->instance;
    my $dbh = $mh->dbh( 'db_example' );

=head1 THANKS

Big thanks for L<Dancer::Plugin::Database> for being an inspiration
and example on how to verify database connection is still working.

=head1 AUTHOR

Mikko Koivunalho <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2023 by Mikko Koivunalho.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut