File Coverage

blib/lib/DBIx/Interp.pm

Criterion	Covered	Total	%
statement	137	228	60.0
branch	23	66	34.8
condition	3	12	25.0
subroutine	32	52	61.5
pod	4	4	100.0
total	199	362	54.9

package DBIx::Interp;

use strict;
use warnings;
use Carp;
use SQL::Interp ':all';
use base 'DBI';
use Exporter 'import';


our $VERSION = '1.26';

our %EXPORT_TAGS = (all => [qw(
    attr dbi_interp key_field
    sql_interp sql_interp_strict sql_type sql
)]);
our @EXPORT_OK = @{$EXPORT_TAGS{all}};

our @CARP_NOT =
    qw(DBIx::Interp DBIx::Interp::db DBIx::Interp::STX);

sub key_field {
    my $key = shift;
    return bless \$key, "DBIx::Interp::Key";
}

sub attr {
    return bless {@_}, "DBIx::Interp::Attr";
}

sub dbi_interp {
    return DBIx::Interp::db::dbi_interp(@_);
}

sub new {
    shift;
    return DBIx::Interp::db->new(@_);
}

sub _wrap(&) {
    my $code = shift;
    my $x;
    my @x;
    my $want = wantarray();
    eval {
        if ($want) { @x = $code->(); }
        else       { $x = $code->(); }
    };
    if ($@) { croak $@; }
    return $want ? @x : $x;
}

#####
package DBIx::Interp::db;
use strict;
use warnings;
use Carp;
use base 'DBI::db';
use Scalar::Util 'weaken';

our @CARP_NOT = @DBIx::Interp::CARP_NOT;

my $priv = 'private_DBIxInterpolate';

sub new {
    my $class = shift;
    my $dbh;

    if (UNIVERSAL::isa($_[0], 'DBI::db')) {
        $dbh = shift;
    }
    elsif (ref $_[0] eq 'ARRAY') {
        $dbh = DBI->connect(@{shift @_});
        return if ! defined $dbh;
    }
    else {
        croak 'DBIx::Interp::db::new() not passed database connection';
    }

    my $interp = SQL::Interp->new(($dbh || ()), @_);
    my $self = $dbh;
    bless $self, $class;
    my $private = $self->{$priv} = {};
    $private->{stx} = $self->prepare_i();
    $private->{interp} = $interp;

    # weaken circular references to allow garbage collection
    weaken $private->{stx}->{dbx};
    weaken $private->{interp}->{dbh};

    return $self;
}

#sub DESTROY {
#    my ($self) = @_;
#    $self->SUPER::DESTROY();
#}

sub connect {
    my $class = shift;
    my $self;
    eval {
        my $dbh = DBI->connect(@_);
        return if ! $dbh;
        $self = DBIx::Interp->new($dbh);  #Q: OK?
    };
    if ($@) { croak $@; }
    return $self;
}

# removed in 0.40:
#sub dbh


# new in 0.31
sub stx {
    my $self = shift;
    return $self->{$priv}->{stx};
}

# new in 0.40
sub interp {
    my $self = shift;
    return $self->{$priv}->{interp};
}

sub dbi_interp {
    my $key;
    my $attr;
    my @args = grep {
        my $save = 1;
        if (ref($_) eq 'DBIx::Interp::Key') {
            $key = $_; $save = 0;
        }
        elsif (ref($_) eq 'DBIx::Interp::Attr') {
            $attr = {%$_}; $save = 0;
        }
        $save;
    } @_;
    my ($sql, @bind) = sql_interp(@args);
    my @params = ($sql);
    push @params, $$key if defined $key;
    push @params, $attr, @bind;
    return @params;
}

sub sql_interp {
    my (@params) = @_;
    if (UNIVERSAL::isa($_[0], 'DBIx::Interp::db')) {
        my $self = shift;
        return SQL::Interp::sql_interp($self->interp(), @_);
    }
    else {
        return SQL::Interp::sql_interp(@_);
    }
}

# based on function in DBI
sub _do_selectrow_i {
    my ($self, $method, @list) = @_;

    #my $sth = $dbh->prepare($stmt, $attr) or return;
    #_do_execute($sth, @bind) or return;
    my $stx = $self->{$priv}->{stx};
    $stx->execute_i(@list) or return;
    my $sth = $stx->sth();
    my $row = $sth->$method() and $sth->finish;
    return $row;
}

# new in 0.40
sub prepare_i {
    my ($self) = @_;
    return DBIx::Interp::STX->new($self);
}

# new in 0.40
sub do_i {
    my ($self, @list) = @_;
    return _wrap {
        # based on DBI::do
        #   my $sth = $dbh->prepare($sql, $attr) or return undef;
        #   _do_execute(@bind) or return undef;
        my $stx = $self->{$priv}->{stx};
        $stx->execute_i(@list) or return undef;
        my $sth = $stx->sth();
        my $rows = $sth->rows;
        return ($rows == 0) ? "0E0" : $rows;
    };
}

# new in 0.40
sub selectrow_array_i {
    my ($self, @list) = @_;
    my $want = wantarray;
    return _wrap {
        # based on DBI::selectrow_array

        my $row = $self->_do_selectrow_i('fetchrow_arrayref', @list)
            or return;
        return $row->[0] unless $want;
        return @$row;
    };
}

# new in 0.40
sub selectrow_arrayref_i {
    my ($self, @list) = @_;
    return _wrap {
        # based on DBI::selectrow_arrayref

        return $self->_do_selectrow_i('fetchrow_arrayref', @list);
    };
}

# new in 0.40
sub selectrow_hashref_i {
    my ($self, @list) = @_;
    return _wrap {
        # based on DBI::selectrow_hashref

        return $self->_do_selectrow_i('fetchrow_hashref', @list);
    };
}

# new in 0.40
sub selectall_arrayref_i {
    my ($self, @list) = @_;
    return _wrap {
        # improve: no need to to a full dbi_interp call here and elsewhere
        my ($sql, $attr, @bind) = $self->dbi_interp(@list); # need $attr

        # based on DBI::selectall_arrayref
        #   my $sth = $dbh->prepare($sql, $attr) or return;
        #   _do_execute($sth, @bind) or return;

        my $stx = $self->{$priv}->{stx};
        $stx->execute_i(@list) or return;
        my $sth = $stx->sth();
        # typically undef, else hash or array ref
        my $slice = $attr->{Slice};
        if (!$slice and $slice=$attr->{Columns}) {
            if (ref $slice eq 'ARRAY') {
                $slice = [ @{$attr->{Columns}} ];
                for (@$slice) { $_-- }
            }
        }
        my $rows = $sth->fetchall_arrayref(
            $slice, my $MaxRows = $attr->{MaxRows});
        $sth->finish if defined $MaxRows;
        return $rows;
    };
}

# new in 0.40
sub selectall_hashref_i {
    my ($self, @list) = @_;
    return _wrap {
        #need $key_field
        my ($sql, $key_field, $attr, @bind) = $self->dbi_interp(@list);

        # based on DBI::selectall_hashref
        #   my $sth = $dbh->prepare($sql, $attr);
        #   return unless $sth;
        #   _do_execute($sth, @bind) or return;

        my $stx = $self->{$priv}->{stx};
        $stx->execute_i(@list) or return;
        my $sth = $stx->sth();
        return $sth->fetchall_hashref($key_field);
    };
}

# new in 0.40
sub selectcol_arrayref_i {
    my ($self, @list) = @_;
    return _wrap {
        my ($sql, $attr, @bind) = $self->dbi_interp(@list); # need $attr

        # based on DBI::selectcol_arrayref
        #   my $sth = $dbh->prepare($sql, $attr);
        #   return unless $sth;
        #   _do_execute($sth, @bind) or return;

        my $stx = $self->{$priv}->{stx};
        $stx->execute_i(@list) or return;
        my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1);
        my @values  = (undef) x @columns;
        my $idx = 0;
        my $sth = $stx->sth();
        for (@columns) {
            $sth->bind_col($_, \$values[$idx++]) or return;
        }
        my @col;
        if (my $max = $attr->{MaxRows}) {
            push @col, @values while @col<$max && $sth->fetch;
        }
        else {
            push @col, @values while $sth->fetch;
        }
        return \@col;
    };
}

1;

#####
package DBIx::Interp::STX;
use strict;
use warnings;
use Carp;

our @CARP_NOT = @DBIx::Interp::CARP_NOT;

sub new {
    my ($class, $dbx) = @_;
    my $self = bless {
        # active sth
        sth => undef,

        # map: SQL --> sth (sth cache)
        sths => {},

        # queue of SQL. used to select sth to delete if cache is full
        sql_queue => [],

        # DBIx::Interp
        dbx => $dbx,

        # max sths allowed in the cache
        max_sths => 1
    }, $class;
    return $self;
}

sub max_sths {
    my ($self, $max_sths) = @_;
    if (defined $max_sths) {
        $self->{max_sths} = $max_sths;
    }
    else {
        return $self->{max_sths};
    }
}

sub sth {
    my $self = shift;
    return $self->{sth};
}

sub sths {
    my $self = shift;
    return {%{$self->{sths}}};
}

# renamed execute --> execute_i in 0.40
sub execute_i {
    my ($self, @list) = @_;

    return DBIx::Interp::_wrap {
        my ($sql, @bind) = $self->{dbx}->dbi_interp(@list);
        shift @bind if defined $bind[0] && ref $bind[0] eq ''; # remove any key_field()
        my $attr = shift @bind;
        my $sth = $self->{sths}->{$sql};
        if (! defined $sth) {
            $sth = $self->{dbx}->prepare($sql, $attr) or return;
            if (@{$self->{sql_queue}} + 1 > $self->{max_sths}) {
                my $sql_remove = shift @{$self->{sql_queue}};
                delete $self->{sths}->{$sql_remove};
            }
            $self->{sths}->{$sql} = $sth;
            push @{$self->{sql_queue}}, $sql;
        }
        $self->{sth} = $sth;
        _bind_params($sth, @bind);
        return $sth->execute();
    };
}

sub _bind_params {
    my ($sth, @bind) = @_;
    my $num = 1;
    return DBIx::Interp::_wrap {
        if (ref($bind[0]) eq 'ARRAY') {
            for my $val (@bind) {
                $sth->bind_param($num++, $val->[0], $val->[1]->{type});
            }
        }
        else {
            for my $val (@bind) {
                $sth->bind_param($num++, $val);
            }
        }
    };
}

sub fetchrow_arrayref {
    my $self = shift;
    return DBIx::Interp::_wrap {
        return $self->{sth}->fetchrow_arrayref();
    };
}

sub fetchrow_array {
    my $self = shift;
    return DBIx::Interp::_wrap {
        return $self->{sth}->fetchrow_array();
    };
}

sub fetchrow_hashref {
    my ($self, @params) = @_;
    return DBIx::Interp::_wrap {
        return $self->{sth}->fetchrow_hashref(@params);
    };
}

sub fetchall_arrayref {
    my ($self, @params) = @_;
    return DBIx::Interp::_wrap {
        return $self->{sth}->fetchall_arrayref(@params);
    };
}

sub fetchall_hashref {
    my ($self, @params) = @_;
    return DBIx::Interp::_wrap {
        return $self->{sth}->fetchall_hashref(@params);
    };
}

1;

__END__