Database connector for Perl

Client.pm

# this should go into a directory called "Tools/Database" and be called "Client.pm"
package Tools::Database::Client;

use strict;
use warnings FATAL => 'all';

use Try::Tiny;
use Tools::Database;

use Carp;
our @CARP_NOT = qw(Try::Tiny);

sub new {
    my ($class, $source, $username, $password, $options, $client_id) = @_;

    # the client_id allows us to connect to the same database multiple times
    $client_id ||= 'default';

    return bless({
        '_dsn'       => [ $source, $username, $password, $options ],
        '_client_id' => $client_id,
        '_dbh'       => undef,
    }, $class);
}

sub dbh {
    my $self = shift;
    my %args = @_;

    # try for 360 times by default. this allows roughly one hour to restart the database
    my $tries = $args{'tries'} || 360;

    my $dbh = undef;
    my $successful = 0;
    my $failed = 0;

    do {
        $successful = try {
            my $db = Tools::Database->instance();
            $dbh = $db->dbh(@{$self->{'_dsn'}}, $self->{'_client_id'});

            # make sure the connection got created
            if (!defined($dbh) || $db->is_dbh_down(@{$self->{'_dsn'}}, $self->{'_client_id'})) {
                die "connection did not return a connected handle\n";
            }

            return 1;
        } catch {
            my $error = (defined($_) ? $_ : "unknown error");
            carp "could not get database connection: ${error}";

            ++$failed;
            croak "not waiting for the database any longer" if ($failed >= $tries);

            # wait before trying again
            sleep($args{'sleep'} || 10);

            return 0;
        };
    } while (!$successful);

    return $dbh;
}

sub persistent_dbh {
    my $self = shift;

    if (defined($self->{'_dbh'})) {
        # we have a handle, make sure it is live. if it is not live then
        # clean it and die.
        unless ($self->{'_dbh'}->ping()) {
            $self->{'_dbh'} = undef;
            die "lost connection to database\n";
        }
    } else {
        # we don't have a handle already so create one. this handle will be
        # returned every time persistent_dbh is called.
        $self->{'_dbh'} = $self->dbh(@_);
    }

    return $self->{'_dbh'};
}

1;

=head1 NAME

Tools::Database::Client

=head1 SYNOPSIS

    # create a connection with the client id "default"
    my $db = Tools::Database::Client->new("dbi:Pg:dbname=foo;host=foo.example.com");

    # this will create another connection to foo.example.com. this
    # singleton can only be accessed with the client id "foo".
    my $db2 = Tools::Database::Client->new("dbi:Pg:dbname=foo;host=foo.example.com", "foo");

    # get a working database handle. this is not guaranteed to return the same
    # handle with each invocation so only use this if you don't care about
    # transactions.
    my $dbh = $db->dbh();

    # get a working database handle but only try once
    my $dbh = $db->dbh('tries' => 1);

    # get a working database handle but try 10 times, sleeping for one second
    # between each attempt. the default is to sleep for 10 seconds.
    my $dbh = $db->dbh('tries' => 10, 'sleep' => 1);

    # get the same connection over and over again and croak if it goes away
    my $dbh = $db->persistent_dbh('tries' => 6);

=head1 DESCRIPTION

This library makes a connection to given database identifier (DSN). If a
connection cannot be made then it will keep trying, every 10 seconds, for up
to an hour to get that connection.

=head2 new

This will return a C object connected to the given
database. This method takes five arguments, four of which are optional:

=over

=item source

The connection string for the database host.

=item username

The username to use when connecting to the database.

=item password

The password to use when connecting to the database.

=item attributes

Any attributes to pass to the database host. By default these attributes are
set:

=over

=item AutoCommit => 1

=item RaiseError => 1

=item PrintError => 0

=item AutoInactiveDestroy => 1

=back

=item clientid

This can be used to connect to the same database multiple times using a
different identifier for each connection.

=back

=head2 dbh

If it does not matter to you whether you get the same handle with each
invocation you can use the C method. If no current database connection
exists or the database went away then the C method will try to connect
to the database. If C is unable to connect to the database then it will
keep trying for up to an hour until it is able to get a connection. After an
hour of not getting a database connection it will croak.

=head2 persistent_dbh

If it B matter to you whether you get the same handle each invocation
then you can use the C method. If no current database
connection exists then the C method will try to connect to the
database. But if there had been a connection and it went away then this method
will die. If C is unable to connect to the database then it
will keep trying for up to an hour until it is able to get a connection. After
an hour of not getting a database connection it will croak.

=cut

Database.pm

# this should go into a directory called "Tools" and be called "Database.pm"
package Tools::Database;

use strict;
use warnings FATAL => 'all';

use Class::Singleton;
use parent qw(Class::Singleton);

use DBI;
use Try::Tiny;
use Storable qw(nfreeze);
use version;

use Carp;
our @CARP_NOT = qw(Try::Tiny);

sub dbh {
    my ($self, $source, $username, $password, $options, $client_id) = @_;
    croak "cannot connect to database -- no DSN given" unless defined($source);

    # the client_id allows us to connect to the same database multiple times
    $client_id ||= 'default';

    # add standard options to the dsn
    $options = $self->_add_dbi_options($options);

    my $dbh_id = $self->_get_dbh_id();
    my $dsn_id = $self->_serialize_dsn($source, $username, $password, $options, $client_id);
    my $dbh = $self->{'_dbhs'}->{$dbh_id}->{$dsn_id}->{'dbh'};

    return try {
        if (defined($dbh) && ref($dbh) eq "DBI::db") {
            if ($dbh->ping()) {
                return $dbh;
            } else {
                croak "lost connection to database";
            }
        }

        # actually try to connect to the database
        $dbh = DBI->connect($source, $username, $password, $options) or croak $DBI::errstr;

        # put the database handle into memory
        $self->{'_dbhs'}->{$dbh_id}->{$dsn_id} = {
            'dbh' => $dbh,
            'dbh_down' => 0,
        };

        return $dbh;
    } catch {
        my $error = (defined($_) ? $_ : "unknown error");

        # try to rollback if the database is connected and autocommit is disabled
        try { $dbh->rollback() if (defined($dbh) && !$dbh->{'AutoCommit'}); } catch {};

        # try to disconnect
        try { $dbh->disconnect() if defined($dbh); } catch {};

        # remove references to it
        $self->{'_dbhs'}->{$dbh_id}->{$dsn_id} = {
            'dbh' => undef,
            'dbh_down' => 1,
        };

        croak "could not connect to database: ${error}";
    };
}

sub is_dbh_down {
    my ($self, $source, $username, $password, $options, $client_id) = @_;
    croak "cannot check database status -- no DSN given" unless defined($source);

    # the client_id allows us to connect to the same database multiple times
    $client_id ||= 'default';

    # add standard options to the dsn
    $options = $self->_add_dbi_options($options);

    # try to connect to database. this will fail if the database is down and
    # will set the "dbh_down" flag that we check below.
    try { $self->dbh($source, $username, $password, $options, $client_id); } catch {};

    # get identifiers so we can find the dbh we are connecting to
    my $dbh_id = $self->_get_dbh_id();
    my $dsn_id = $self->_serialize_dsn($source, $username, $password, $options, $client_id);

    # if we have no record of this database then it is down
    return 1 unless exists($self->{'_dbhs'}->{$dbh_id}->{$dsn_id});

    # we have a record of the db so return the down value
    return $self->{'_dbhs'}->{$dbh_id}->{$dsn_id}->{'dbh_down'};
}

sub _get_dbh_id {
    my ($self) = @_;

    my $pid_tid = $$;
    $pid_tid .= '_' . threads->tid if $INC{'threads.pm'};

    return $pid_tid;
}

sub _add_dbi_options {
    my ($self, $options) = @_;

    # default dsn options
    $options->{'AutoCommit'} //= 1;
    $options->{'RaiseError'} //= 1;
    $options->{'PrintError'} //= 0;

    if (version->parse(DBI->VERSION) >= version->parse('1.614')) {
        # this option is only valid in more recent version of the dbi,
        # specifically version 1.614 or greater. these options make it such
        # that the database connection will correctly go away if the program
        # forks. NOTE: Do not set 'InactiveDestroy' either by itself or with
        # 'AutoInactiveDestroy'. It will cause memory leaks. This argument will
        # cause the correct thing to happen and avoid memory leaks.
        $options->{'AutoInactiveDestroy'} //= 1;
    }

    return $options;
}

sub _serialize_dsn {
    my ($self, @dsn) = @_;
    $Storable::canonical = 1;
    return nfreeze(\@dsn);
}

1;

=head1 NAME

Tools::Database

=head1 SYNOPSIS

    use Tools::Database;

    my $db = Tools::Database->instance();
    my $dbh1 = $db->dbh("dbi:Pg:dbname=foo;host=foo.example.com");
    my $dbh2 = $db->dbh("dbi:Pg:dbname=bar;host=bar.example.com", "username", "password", {}, "conn1");

=cut