view release on metacpan or  search on metacpan

lib/App/Kit/Obj/DB.pm  view on Meta::CPAN

package App::Kit::Obj::DB;

## no critic (RequireUseStrict) - Moo does strict
use Moo;

our $VERSION = '0.2';

Sub::Defer::defer_sub __PACKAGE__ . '::conn' => sub {
    require DBI;
    return sub {
        my ( $self, @connect ) = @_;

        my $dbh = DBI->connect(@connect) || die "Could not connect to database: " . DBI->errstr();

        # TODO: similar thing for other drivers ?
        if ( $dbh->{Driver}{Name} eq 'mysql' ) {
            $dbh->do('SET CHARACTER SET utf8') or die $dbh->errstr;
            $dbh->do("SET NAMES 'utf8'")       or die $dbh->errstr;

            # This will make sure TZ offsets don't goof your datetime queries.
            #     Human readable results will of course need adjusted (and formatted) (hint: locale->datetime(…))
            #         which they would anyway, this just makes it easier to know you are in a universally sane state:
            # Add UTC via: mysql_tzinfo_to_sql /usr/share/zoneinfo/ | mysql -u root mysql -p
            $dbh->do(q{SET time_zone = 'UTC'});    # or die $dbh->errstr;
        }
        elsif ( $dbh->{Driver}{Name} eq 'SQLite' ) {
            $dbh->do('PRAGMA encoding = "UTF-8"');    # probably too late, default anyway. so at worst a no-op; at best we get utf-8
        }

        return $dbh;
    };
};

has _app => (
    is       => 'ro',
    required => 1,
);

has dbh_is_still_good_check => (                      # e.g. only ping() every N calls/seconds
    is  => 'rw',
    isa => sub { die "'dbh_is_still_good_check' must be undef or a coderef" unless !defined $_[0] || ref $_[0] eq 'CODE' },
    default => sub { undef },
);

has _dbh => (
    is => 'rwp',

    # isa => sub { die "'_dbh' must be a DBI::db object\n" unless ref $_[0] eq 'DBI::db' },
    default => sub { undef },
);

sub disconn {
    my ( $self, $dbh ) = @_;

    if ($dbh) {
        $dbh->disconnect || return;
    }
    else {
        if ( defined $self->_dbh ) {
            my $dbh = $self->_dbh;
            $self->_set__dbh(undef);
            $dbh->disconnect || return;
        }
    }

    return 1;
}

Sub::Defer::defer_sub __PACKAGE__ . '::dbh' => sub {
    require DBI;
    return sub {
        my ( $self, $dbi_conf ) = @_;

        if ( defined $dbi_conf && ref($dbi_conf) eq 'HASH' && $dbi_conf->{'_force_new'} ) {
            $self->disconn;
            if ( keys %{$dbi_conf} == 1 ) {
                $dbi_conf = undef;
            }
        }

        if ( !$self->_dbh || ( defined $self->dbh_is_still_good_check ? !$self->dbh_is_still_good_check->( $self->_dbh ) : !$self->_dbh->ping ) ) {