File Coverage

lib/DBIx/DR.pm

Criterion	Covered	Total	%
statement	104	115	90.4
branch	24	44	54.5
condition	10	20	50.0
subroutine	22	26	84.6
pod	1	1	100.0
total	161	206	78.1

use utf8;
use strict;
use warnings;

use DBIx::DR::Iterator;
use DBIx::DR::Util ();
use DBIx::DR::PlPlaceHolders;

package DBIx::DR;
our $VERSION = '0.30';
use base 'DBI';
use Carp;
$Carp::Internal{ (__PACKAGE__) } = 1;

sub connect {
    my ($class, $dsn, $user, $auth, $attr) = @_;

    my $dbh = $class->SUPER::connect($dsn, $user, $auth, $attr);

    $attr = {} unless ref $attr;

    $dbh->{"private_DBIx::DR_iterator"} =
        $attr->{dr_iterator} || 'dbix-dr-iterator#new';

    $dbh->{"private_DBIx::DR_item"} =
        $attr->{dr_item} || 'dbix-dr-iterator-item#new';

    $dbh->{"private_DBIx::DR_sql_dir"} = $attr->{dr_sql_dir};

    $dbh->{"private_DBIx::DR_template"} = DBIx::DR::PlPlaceHolders->new(
        sql_dir     => $attr->{dr_sql_dir},
        sql_utf8    => $attr->{dr_sql_utf8} // 1
    );

    $dbh->{"private_DBIx::DR_dr_decode_errors"} = $attr->{dr_decode_errors};

    return $dbh;
}

package DBIx::DR::st;
use base 'DBI::st';
use Carp;
$Carp::Internal{ (__PACKAGE__) } = 1;

package DBIx::DR::db;
use Encode qw(decode encode);
use base 'DBI::db';
use DBIx::DR::Util;
use File::Spec::Functions qw(catfile);
use Carp;
$Carp::Internal{ (__PACKAGE__) } = 1;


sub set_helper {
    my ($self, %opts) = @_;
    $self->{"private_DBIx::DR_template"}->set_helper(%opts);
}

sub _dr_extract_args_ep {
    my $self = shift;

    my (@sql, %args);

    if (@_ % 2) {
        ($sql[0], %args) = @_;
        delete $args{-f};
    } else {
        %args = @_;
    }

    croak "SQL wasn't defined" unless @sql or $args{-f};

    my ($iterator, $item);

    unless ($args{-noiterator}) {
        $iterator = $args{-iterator} || $self->{'private_DBIx::DR_iterator'};
        croak "Iterator class was not defined" unless $iterator;

        unless($args{-noitem}) {
            $item = $args{-item} || $self->{'private_DBIx::DR_item'};
            croak "Item class was not definded" unless $item;
        }
    }

    return (
        $self,
        \@sql,
        \%args,
        $item,
        $iterator,
    );
}



sub _user_sql($@) {
    my ($sql, @bv) = @_;
    $sql =~ s/\?/'$_'/ for @bv;
    return $sql;
}


sub select {
    my ($self, $sql, $args, $item, $iterator) = &_dr_extract_args_ep;

    my $req = $self->{"private_DBIx::DR_template"}->sql_transform(
        @$sql,
        %$args
    );

    carp  _user_sql($req->sql, $req->bind_values) if $args->{'-warn'};
    croak _user_sql($req->sql, $req->bind_values) if $args->{'-die'};

    my $res;

    local $SIG{__DIE__} = sub { croak $self->_dr_decode_err(@_) };

    if (exists $args->{-hash}) {
        $res = $self->selectall_hashref(
                $req->sql,
                $args->{-hash},
                $args->{-dbi},
                $req->bind_values
            );

    } else {
        my $dbi = $args->{-dbi} // {};
        croak "argument '-dbi' must be HASHREF or undef"
            unless 'HASH' eq ref $dbi;
        $res = $self->selectall_arrayref(
                $req->sql,
                { %$dbi, Slice => {} },
                $req->bind_values
            );
    }


    return $res unless $iterator;

    my ($class, $method) = camelize $iterator;

    return $class->$method(
        $res, -item => $item, -noitem_iter => $args->{-noitem_iter}) if $method;
    return bless $res => $class;
}

sub single {
    my ($self, $sql, $args, $item) = &_dr_extract_args_ep;
    my $req = $self->{"private_DBIx::DR_template"}->sql_transform(
        @$sql,
        %$args
    );

    carp  _user_sql($req->sql, $req->bind_values) if $args->{'-warn'};
    croak _user_sql($req->sql, $req->bind_values) if $args->{'-die'};

    local $SIG{__DIE__} = sub { croak $self->_dr_decode_err(@_) };
    my $res = $self->selectrow_hashref(
            $req->sql,
            $args->{-dbi},
            $req->bind_values
        );

    return unless $res;

    my ($class, $method) = camelize $item;
    return $class->$method($res) if $method;
    return bless $res => $class;
}

sub perform {
    my ($self, $sql, $args) = &_dr_extract_args_ep;
    my $req = $self->{"private_DBIx::DR_template"}->sql_transform(
        @$sql,
        %$args
    );

    carp  _user_sql($req->sql, $req->bind_values) if $args->{'-warn'};
    croak _user_sql($req->sql, $req->bind_values) if $args->{'-die'};

    local $SIG{__DIE__} = sub { croak $self->_dr_decode_err(@_) };
    my $res = $self->do(
            $req->sql,
            $args->{-dbi},
            $req->bind_values
        );
    return $res;
}


sub _dr_decode_err {
    my ($self, @arg) = @_;
    if ($self->{"private_DBIx::DR_dr_decode_errors"}) {
        for (@arg) {
            $_ = eval { decode utf8 => $_ } || $_ unless utf8::is_utf8 $_;
        }
    }
    return @arg if wantarray;
    return join ' ' => @arg;
}


1;

__END__