view release on metacpan or  search on metacpan

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

use strict;
use warnings;
use MRO::Compat 'c3';

package DBIx::FlexibleBinding;
our $VERSION = '2.0.4'; # VERSION
# ABSTRACT: Greater statement placeholder and data-binding flexibility.
use DBI             ();
use Exporter        ();
use Message::String ();
use Scalar::Util    ( 'reftype', 'blessed', 'weaken' );
use Sub::Util       ( 'set_subname' );
use namespace::clean;
use Params::Callbacks ( 'callback' );
use message << 'EOF';
CRIT_EXP_AREF_AFTER Expected a reference to an ARRAY after argument (%s)
CRIT_UNEXP_ARG      Unexpected argument (%s)
CRIT_EXP_SUB_NAMES  Expected a sub name, or reference to an array of sub names
CRIT_EXP_HANDLE     Expected a %s::database or statement handle 
CRIT_DBI            A DBI error occurred\n%s 
CRIT_PROXY_UNDEF    Handle (%s) undefined 
EOF

our @ISA                  = qw(DBI Exporter);
our @EXPORT               = qw(callback);
our $AUTO_BINDING_ENABLED = 1;

sub _is_arrayref
{
    return ref( $_[0] ) && reftype( $_[0] ) eq 'ARRAY';
}

sub _is_hashref
{
    return ref( $_[0] ) && reftype( $_[0] ) eq 'HASH';
}

sub _as_list_or_ref
{
    return wantarray ? @{ $_[0] } : $_[0]
        if defined $_[0];
    return wantarray ? () : undef;
}

sub _create_namespace_alias
{
    my ( $package, $ns_alias ) = @_;
    return $package unless $ns_alias;
    no strict 'refs';
    for ( '', 'db', 'st' ) {
        my $ext .= $_ ? "\::$_" : $_;
        $ext .= '::';
        *{ $ns_alias . $ext } = *{ $package . $ext };
    }
    return $package;
}

sub _create_dbi_handle_proxies
{
    my ( $package, $caller, $list_of_sub_names ) = @_;
    return $package unless $list_of_sub_names;
    if ( ref $list_of_sub_names ) {
        CRIT_EXP_SUB_NAMES
            unless _is_arrayref( $list_of_sub_names );
        for my $sub_name ( @$list_of_sub_names ) {
            $package->_create_dbi_handle_proxy( $caller, $sub_name );
        }
    }
    else {
        $package->_create_dbi_handle_proxy( $caller, $list_of_sub_names );
    }
    return $package;
}

our %proxies;

sub _create_dbi_handle_proxy
{
    # A DBI Handle Proxy is a subroutine masquerading as a database or
    # statement handle object in the calling package namespace. They're
    # intended to function as a pure convenience if that convenience is
    # wanted.
    my ( $package, $caller, $sub_name ) = @_;
    my $fqpi = "$caller\::$sub_name";
    no strict 'refs';
    *$fqpi = set_subname(
        $sub_name => sub {
            unshift @_, ( $package, $fqpi );
            goto &_service_call_to_a_dbi_handle_proxy;
        }
    );
    $proxies{$fqpi} = undef;
    return $package;
}

sub _service_call_to_a_dbi_handle_proxy
{
    # This is the handler servicing calls to a DBI Handle Proxy. It
    # imparts a set of overloaded behaviours on the object, each
    # triggered by a different usage context.
    my ( $package, $fqpi, @args ) = @_;
    return $proxies{$fqpi}
        unless @args;
    if ( @args == 1 ) {
        unless ( $args[0] ) {
            undef $proxies{$fqpi};
            return $proxies{$fqpi};
        }
        if ( blessed( $args[0] ) ) {
            if ( $args[0]->isa( "$package\::db" ) ) {
                weaken( $proxies{$fqpi} = $args[0] );
            }
            elsif ( $args[0]->isa( "$package\::st" ) ) {
                weaken( $proxies{$fqpi} = $args[0] );
            }
            else {
                CRIT_EXP_HANDLE( $package );
            }
            return $proxies{$fqpi};
        }
    }
    if ( $args[0] =~ m{^dbi:}i ) {
        $proxies{$fqpi} = $package->connect( @args )
            or CRIT_DBI( $DBI::errstr );
    }
    else {
        CRIT_PROXY_UNDEF( $fqpi )
            unless $proxies{$fqpi};
        my $proxy = $proxies{$fqpi};
        $proxy->execute( @args )
            if $proxy->isa( "$package\::st" );
        return $proxy->getrows( @args );
    }
    return $proxies{$fqpi};
}

sub import
{
    my ( $package, @args ) = @_;
    my $caller = caller;
    @_ = ( $package );

    while ( @args ) {
        my $arg = shift( @args );

        if ( substr( $arg, 0, 1 ) eq '-' ) {
            if ( $arg eq '-alias' || $arg eq '-as' ) {
                my $ns_alias = shift @args;
                $package->_create_namespace_alias( $ns_alias );
            }
            elsif ( $arg eq '-subs' ) {
                my $list_of_sub_names = shift @args;
                $package->_create_dbi_handle_proxies( $caller, $list_of_sub_names );
            }
            else {
                CRIT_UNEXP_ARG( $arg );
            }
        }
        else {
            push @_, $arg;
        }
    }

    goto &Exporter::import;
}

sub connect
{
    my ( $invocant, $dsn, $user, $pass, $attr ) = @_;
    $attr = {}
        unless defined $attr;
    $attr->{RootClass} = ref( $invocant ) || $invocant
        unless defined $attr->{RootClass};
    return $invocant->next::method( $dsn, $user, $pass, $attr );