File Coverage

blib/lib/DBI/Fetch.pm

Criterion	Covered	Total	%
statement	84	197	42.6
branch	35	148	23.6
condition	13	54	24.0
subroutine	14	19	73.6
pod	4	10	40.0
total	150	428	35.0

package DBI::Fetch;

# Copyright (c) 2012 Iain Campbell. All rights reserved.
#
# This work may be used and modified freely, but I ask that the copyright
# notice remain attached to the file. You may modify this module as you
# wish, but if you redistribute a modified version, please attach a note
# listing the modifications you have made.

BEGIN {
    $DBI::Fetch::AUTHORITY = 'cpan:CPANIC';
    $DBI::Fetch::VERSION   = '1.00';
    $DBI::Fetch::VERSION   = eval $DBI::Fetch::VERSION;
}

use 5.008_004;
use strict;
use warnings::register;
use warnings 'all';
use base 'Exporter';

use DBI;

use Params::Callbacks qw/
    callbacks
    /;

use Scalar::Util qw/
    blessed
    reftype
   /;

our @EXPORT;

our @EXPORT_OK = qw/
    process
    /;

our %EXPORT_TAGS = (
    default => \@EXPORT,
    all     => \@EXPORT_OK,
);

our $E_UNIMP_METHOD = 'Method "%s" not implemented by package "%s"';
our $E_NO_DBH       = 'Database handle expected';
our $E_NO_SQL       = 'SQL statement expected';
our $E_EXP_L_REF    = 'Hash or array reference expected';
our $E_EXP_A_REF    = 'Array reference expected';
our $E_EXP_H_REF    = 'Hash reference expected';
our $E_EXP_STH      = 'Statement handle expected but got %s object';

sub is_array_ref { ref $_[0] && reftype $_[0] eq 'ARRAY' }

sub is_hash_ref  { ref $_[0] && reftype $_[0] eq 'HASH' }

sub is_code_ref  { ref $_[0] && reftype $_[0] eq 'CODE' }

our @CONFIG = ( {
    remember_last_used_dbh    => 1,
    return_result_sets_as_ref => 0,
    fetch_row_using           => sub {
        $_[0]->fetchrow_hashref('NAME_lc')
    },
} );

sub throw {
    @_ = $@ = ref $_[0] ? ref $_[0] : sprintf @_ ? shift : $@, @_ ;
    defined &Carp::croak ? goto &Carp::croak : die;
};

sub config {
    shift if @_ && __PACKAGE__ eq "$_[0]";

   if (@_) {
        if (is_hash_ref($_[0])) {
            $CONFIG[-1] = shift;
        }
        else {
            my %config = @_;

            while (my ($key, $value) = each %config) {
                $CONFIG[-1]{$key} = $value;

                if ($key eq 'dbh' && !exists($config{remember_last_used_dbh})) {
                    $config{remember_last_used_dbh} = $CONFIG[-1]{$key} ? 0 : 1;
                }
            }
        }
    }

    return $CONFIG[-1];
}

sub push_config {
    shift if @_ && __PACKAGE__ eq "$_[0]";
    push @CONFIG, { %{ $CONFIG[-1] } };
    @_ ? &config : $CONFIG[-1];
}

sub pop_config {
    shift if @_ && __PACKAGE__ eq "$_[0]";
    pop @CONFIG if @CONFIG > 1;
    @_ ? &config : $CONFIG[-1];
}

# Determine number and style of placeholders used in the SQL statement. A
# hash-reference containing "style" and "count" elements is returned. If
# no placeholders were found then undef is returned.

sub placeholder_disposition {
    shift if @_ && __PACKAGE__ eq "$_[0]";

    my $sql = shift
        or return;

    my $count = 0;
    my $style = undef;

    $count += 1 while $sql =~ m{:\d+\b}gso;

    if ($count) {
        $style = ':1';
    }
    else {
        $count += 1 while $sql =~ m{:\w+\b}gso;

        if ($count) {
            $style = ':name';
        }
        else {
            $count += 1 while $sql =~ m{\?}gso;
            $style = '?' if $count;
        }
    }

    wantarray ? ( style => $style, count => $count ) : $style;
}

# If the statement contains :1-style or :name-style placeholders then they
# will be converted to the standard ?-style placeholders and parameters
# are ordered accordingly.

sub normalize {
    shift if @_ && __PACKAGE__ eq "$_[0]";

    my $sql = shift
        or return;

    my $style = placeholder_disposition($sql)
        or return $sql;

    my $params = do {
        my $argc = @_;

        if ($style eq ':name') {
            if ($argc == 1 && is_hash_ref($_[0])) {
                +{ %{ $_[0] } };
            }
            elsif ($argc == 1 && is_array_ref($_[0])) {
                +{ @{ $_[0] } };
            }
            else {
                +{ @_ };
            }
        }
        elsif ($style eq ':1') {
            my $position = 0;

            if ($argc == 1 && is_hash_ref($_[0])) {
                +{ %{ $_[0] } };
            }
            elsif ($argc == 1 && is_array_ref($_[0])) {
                +{ map { ( ':' . ++$position => $_ ) } @{ $_[0] } };
            }
            else {
                +{ map { ( ':' . ++$position => $_ ) } @_ };
            }
        }
        else {
            if ($argc == 1 && is_array_ref($_[0])) {
                [ @{ $_[0] } ];
            }
            else {
                [ @_ ];
            }
        }
    };

    if (is_hash_ref($params)) {
        for my $k (keys %{$params}) {
            unless (substr($k, 0, 1) eq ':') {
                $params->{':' . $k} = delete $params->{$k};
            }
        }

        my @ph_names;

        while ($sql =~ m{(:\w+)\b}gso) {
            push @ph_names, $1;
        }

        for my $name (@ph_names) {
            my $value = $params->{$name};

            if (is_array_ref($value)) {
                unless ($#{$value} == 1 && is_hash_ref($value->[1])) {
                    my $replacement = join ', ', map { '?' } @{$value};
                    s{$name\b}{$replacement}gs for $sql;
                    next;
                }
            }

            s{$name\b}{?}gs for $sql;
        }

        $params = [ map {
            my $value = $params->{$_};
            if (is_array_ref($value)) {
                $#{$value} == 1 && is_hash_ref($value->[1]) ? $value : @{$value};
            }
            else {
                $value;
            }
        } @ph_names ];
    }

    return $sql, @{$params};
}

# Prepare (if necessary), bind parameters to and execute the SQL statement
# applying any optional callbacks to the result. The result is returned as
# reference.

sub process {
    shift if @_ && __PACKAGE__ eq "$_[0]";

    my ($callbacks, @args) = &callbacks;

    my $config = $CONFIG[-1];

    my $dbh = do {
        if (is_code_ref($args[0])) {
            $args[0] = $args[0]->();
        }

        if (my $class = blessed $args[0]) {
            if ($class->can('prepare')) {
                shift @args;
            }
        }
    };

    if ($dbh) {
        $config->{dbh} = $dbh if $config->{remember_last_used_dbh};
    }
    else {
        $dbh = $config->{dbh};
    }

    throw $E_NO_DBH unless $dbh;

    my $sth = do {
        if (is_code_ref($args[0])) {
            $args[0] = $args[0]->();
        }

        if (my $class = blessed $args[0]) {
            if ($class->can('execute')) {
                shift @args;
            }
            else {
                throw $E_EXP_STH, $class;
            }
        }
        else {
            undef;
        }
    };

    if ($sth) { # Statement was already prepared...
        if ($sth->{NUM_OF_PARAMS}) {
            my $sql = $sth->{Statement};
            my $style = placeholder_disposition($sql);

            if ($style eq ':name') {
                my %params = @args;

                while ($sql =~ m{:(\w+)\b}gso) {
                    my $name = $1;
                    my $value = exists $params{$name}
                        ? $params{$name}    : exists $params{":$name"}
                        ? $params{":$name"} : undef;
                    if (is_array_ref($value)) {
                        if ($#{$value} == 1 && is_hash_ref($value->[1])) {
                            $sth->bind_param(":$name", @{$value});
                        }
                    }
                    else {
                        $sth->bind_param(":$name", $value);
                    }
                }
            }
            elsif ($style eq ':1') {
                for my $position (1 .. @args) {
                    my $arg = $args[ $position - 1 ];
                    if (is_array_ref($arg)) {
                        if ($#{$arg} == 1 && is_hash_ref($arg->[1])) {
                            $sth->bind_param(":$position", @{$arg});
                        }
                    }
                    else {
                        $sth->bind_param(":$position", $arg);
                    }
                }
            }
            else {
                for my $position (1 .. @args) {
                    my $arg = $args[ $position - 1 ];
                    if (is_array_ref($arg)) {
                        if ($#{$arg} == 1 && is_hash_ref($arg->[1])) {
                            $sth->bind_param($position, @{$arg});
                        }
                    }
                    else {
                        $sth->bind_param($position, $arg);
                    }
                }
            }
        }
    }
    else { # Statement was not prepared...
        my ($sql, @params) = normalize(@args);

        throw $E_NO_SQL unless $sql;

        eval { $sth = $dbh->prepare($sql) };

        throw if $@;

        if ($sth->{NUM_OF_PARAMS}) {
            for my $position (1 .. @params) {
                my $arg = $params[ $position - 1 ];
                if (is_array_ref($arg)) {
                    if ($#{$arg} == 1 && is_hash_ref($arg->[1])) {
                        $sth->bind_param($position, @{$arg});
                    }
                }
                else {
                    $sth->bind_param($position, $arg);
                }
            }
        }
    }

    eval { $sth->execute };

    throw if $@;

    my @results;

    if ($sth->{NUM_OF_FIELDS}) {
        while (my $row = $config->{fetch_row_using}->($sth)) {
            push @results, $callbacks->yield($row);
        }

        $sth->finish;

        if ($config->{return_result_sets_as_ref}) {
            if ($config->{auto_pop_config}) {
                @CONFIG > 1
                    ? pop_config()
                    : delete $config->{auto_pop_config};
            }

            return \@results;
        }
    }
    else {
        @results = $callbacks->yield($sth->rows);

        $sth->finish;

        if ($config->{auto_pop_config}) {
            @CONFIG > 1
                ? pop_config()
                : delete $config->{auto_pop_config};
        }
    }

    return wantarray
        ? @results
        : @results != 1 ? @results : $results[0];
}

1;

__END__