view release on metacpan or  search on metacpan

lib/DBIx/Sunny.pm  view on Meta::CPAN

package DBIx::Sunny;

use strict;
use warnings;
use 5.008005;
use DBI 1.615;

our $VERSION = '0.9993';
our $SKIP_CALLER_REGEX = qr/^(:?DBIx?|DBD|Try::Tiny|Context::Preserve)\b/;

use parent qw/DBI/;

sub connect {
    my $class = shift;
    my ($dsn, $user, $pass, $attr) = @_;
    $attr->{RaiseError} = 1;
    $attr->{PrintError} = 0;
    $attr->{ShowErrorStatement} = 1;
    $attr->{AutoInactiveDestroy} = 1;
    if ($dsn =~ /^(?i:dbi):SQLite:/) {
        $attr->{sqlite_use_immediate_transaction} = 1;
        $attr->{sqlite_unicode} = 1 unless exists $attr->{sqlite_unicode};
    }
    if ($dsn =~ /^(?i:dbi):mysql:/ && ! exists $attr->{mysql_enable_utf8} && ! exists $attr->{mysql_enable_utf8mb4} ) {
        $attr->{mysql_enable_utf8} = 1;
    }
    if ($dsn =~ /^(?i:dbi):Pg:/ && ! exists $attr->{pg_enable_utf8}) {
        $attr->{pg_enable_utf8} = 1;
    }
    $class->SUPER::connect($dsn, $user, $pass, $attr);
}

package DBIx::Sunny::db;
our @ISA = qw(DBI::db);

use DBIx::Sunny::Util qw/bind_and_execute expand_placeholder/;
use DBIx::TransactionManager 0.13;
use Scalar::Util qw/weaken/;

sub connected {
    my $dbh = shift;
    my ($dsn, $user, $pass, $attr) = @_;
    $dbh->{RaiseError} = 1;
    $dbh->{PrintError} = 0;
    $dbh->{ShowErrorStatement} = 1;
    $dbh->{AutoInactiveDestroy} = 1;
    if ($dsn =~ /^dbi:SQLite:/) {
        $dbh->{sqlite_use_immediate_transaction} = 1;
        $dbh->{sqlite_unicode} = 1 unless exists $attr->{sqlite_unicode};

        $dbh->do("PRAGMA journal_mode = WAL");
        $dbh->do("PRAGMA synchronous = NORMAL");

    }
    if ($dsn =~ /^dbi:mysql:/ && ! exists $attr->{mysql_enable_utf8} && ! exists $attr->{mysql_enable_utf8mb4} ) {
        $dbh->{mysql_enable_utf8} = 1;
        $dbh->do("SET NAMES utf8");
    }
    if ($dsn =~ /^dbi:mysql:/) {
        $dbh->{mysql_auto_reconnect} = 0;
    }
    $dbh->{private_connect_info} = [@_];
    $dbh->SUPER::connected(@_);
}

sub connect_info { $_[0]->{private_connect_info} }

sub txn_scope {
    my $self = shift;
    if ( ! $self->{private_txt_manager} ) {
        $self->{private_txt_manager} = DBIx::TransactionManager->new($self);
        weaken($self->{private_txt_manager}->{dbh});
    }
    $self->{private_txt_manager}->txn_scope(
        caller => [caller(0)]
    );
}

sub __set_comment {
    my $self = shift;
    my $query = shift;

    my $trace;
    my $i = 0;
    while ( my @caller = caller($i) ) {
        my $file = $caller[1];
        $file =~ s!\*/!*\//!g;
        $trace = "/* $file line $caller[2] */";
        last if $caller[0] ne ref($self) && $caller[0] !~ $SKIP_CALLER_REGEX;
        $i++;
    }
    $query =~ s! ! $trace !;
    $query;
}

sub prepare {
    my $self = shift;
    my $query = shift;
    $self->SUPER::prepare($self->__set_comment($query), @_);
}

sub do {
    my $self = shift;
    my ($query, $attr, @bind) = @_;
    $self->SUPER::do($self->__set_comment($query), $attr, @bind);
}

sub fill_arrayref {
    my $self = shift;
    return expand_placeholder(@_);
}

sub __prepare_and_execute {
    my $self = shift;
    my ($query, @bind) = expand_placeholder(@_);
    my $sth = $self->prepare($query);
    my $ret = bind_and_execute($sth, @bind);
    return ($sth, $ret);
}

sub select_one {
    my $self = shift;
    my ($sth, $ret) = $self->__prepare_and_execute(@_);
    my $row = $ret && $sth->fetchrow_arrayref;
    return unless $row;
    return $row->[0];
}

sub select_row {
    my $self = shift;
    my ($sth, $ret) = $self->__prepare_and_execute(@_);
    my $row = $ret && $sth->fetchrow_hashref;