File Coverage

blib/lib/DBIx/Interpolate.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package DBIx::Interpolate;

use strict;
use warnings;
use Carp;
use DBI;
use SQL::Interpolate qw(:all);
use base qw(Exporter SQL::Interpolate);

our $VERSION = '0.32';

our @EXPORT;
our %EXPORT_TAGS = (all => [qw(
    attr
    dbi_interp
    key_field
    make_dbi_interp
)]);
our @EXPORT_OK = @{$EXPORT_TAGS{all}};

sub _wrap(&);

# internal helper function to filter use parameters
sub _filter_params {
    my ($skip_names, $skip_keys, @parts) = @_;
    my @out;
    my %skip_names = map {($_=>1)} @$skip_names;
    my %skip_keys  = map {($_=>1)} @$skip_keys;
    while (@parts) {
        if ($skip_names{$parts[0]})   { shift @parts; }
        elsif ($skip_keys{$parts[0]}) { shift @parts; shift @parts; }
        else                          { push @out, shift @parts; }
    }
    return @out;
}

sub import {
    my @params = @_;

    # handle local exports
    my @params2 = _filter_params($SQL::Interpolate::EXPORT_TAGS{all},
                                [SQL::Interpolate::_use_params()], @params);
    __PACKAGE__->export_to_level(1, @params2);

    # pass use parameters to wrapped module.
    # use goto since non-returnable on FILTER => 1.
    @_ = _filter_params($EXPORT_TAGS{all}, [], @params);
    push @_, __WRAP => 1;
    goto &SQL::Interpolate::import; # @_
}

sub new {
    my $class = shift;
    my $dbh;
    if (UNIVERSAL::isa($_[0], 'DBI:db')) {
        $dbh = shift;
    }
    elsif (ref($_[0]) eq 'ARRAY') {
        $dbh = DBI->connect(@{shift @_});
    }

    my $self = SQL::Interpolate->new(($dbh ? $dbh : ()), @_);
    bless $self, $class;
    $self->{stx} = $self->prepare();

    return $self;
}

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

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

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

sub dbi_interp {
    my $key;
    my $attr;
    my @args = grep {
        my $save = 1;
        if (ref($_) eq 'SQL::Interpolate::Key') {
            $key = $_; $save = 0;
        }
        elsif (ref($_) eq 'SQL::Interpolate::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 make_dbi_interp {
    my (@params) = @_;

    my $interp = sub {
        return dbi_interp(@params, @_);
    };
    return $interp;
}

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

sub attr {
    return bless {@_}, "SQL::Interpolate::Attr";
}

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

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

sub prepare {
    my ($self) = @_;
    return DBIx::Interpolate::STX->new($self);
}

sub do {
    my ($self, @list) = @_;
    return _wrap {
        # based on DBI::do
        #   my $sth = $dbh->prepare($sql, $attr) or return undef;
        #   _do_execute(@bind) or return undef;

        $self->{stx}->execute(@list) or return undef;
        my $sth = $self->{stx}->sth();
        my $rows = $sth->rows;
        return ($rows == 0) ? "0E0" : $rows;
    };
}

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

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

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

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

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

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

sub selectall_arrayref {
    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;

        $self->{stx}->execute(@list) or return;
        my $sth = $self->{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;
    };
}

sub selectall_hashref {
    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;

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

sub selectcol_arrayref {
    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;

        $self->{stx}->execute(@list) or return;
        my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1);
        my @values  = (undef) x @columns;
        my $idx = 0;
        my $sth = $self->{stx}->sth();
        for (@columns) {
            $sth->bind_col($_, \$values[$idx++]) || 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;
    };
}

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;
}

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

1;

package DBIx::Interpolate::STX;
use strict;

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::Interpolate
        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}}};
}

sub execute {
    my ($self, @list) = @_;
    my $dbx = $self->{dbx};
    return DBIx::Interpolate::_wrap {
        my ($sql, @bind) = $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) {
	  my $dbx = $self->{dbx};
            $sth = $dbx->dbh()->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::Interpolate::_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::Interpolate::_wrap {
        return $self->{sth}->fetchrow_arrayref();
    };
}

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

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

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

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

1;

__END__