File Coverage

blib/lib/CGI/Application/Plugin/DBH.pm

Criterion	Covered	Total	%
statement	56	58	96.5
branch	30	34	88.2
condition	17	24	70.8
subroutine	8	8	100.0
pod	3	3	100.0
total	114	127	89.7

package CGI::Application::Plugin::DBH;
{
  $CGI::Application::Plugin::DBH::VERSION = '4.04';
}
use parent 'Exporter';

# ABSTRACT: Easy DBI access from CGI::Application

use strict;
use Carp;

our @EXPORT_OK = qw(
    dbh
    dbh_config
    dbh_default_name
);

sub dbh {
    my $self = shift;
    my $name = shift;

    $self->{__DBH_DEFAULT_NAME} ||= "__cgi_application_plugin_dbh";     # First use case.
    $name ||= $self->{__DBH_DEFAULT_NAME};                              # Unnamed handle case.

    unless ($self->{__DBH_CONFIG}{$name}){
        __auto_config($self, $name);
        croak "must call dbh_config() before calling dbh()." unless $self->{__DBH_CONFIG}{$name};
    }

    unless( defined($self->{__DBH}{$name}) && $self->{__DBH}{$name}->ping ) {
        # create DBH object
        if(my $config = $self->{__DBH_CONFIG}{$name} ) {
            # Use a callback
            if (ref $config && ref $config eq 'CODE') {
                $self->{__DBH}{$name} = $config->();
            }
            # use the parameters the user supplied
            else {
                require DBI;
                $self->{__DBH}{$name} = DBI->connect(@{ $self->{__DBH_CONFIG}{$name} });
            }
        } else {
        }
    }

    return $self->{__DBH}{$name};
}

sub dbh_config {
    my $self = shift;

    $self->{__DBH_DEFAULT_NAME} ||= "__cgi_application_plugin_dbh";     # First use case.

    my $name = shift if( ref($_[1]) );
    $name ||= $self->{__DBH_DEFAULT_NAME};                              # Unnamed handle case.

    croak "Calling dbh_config after the dbh has already been created" if( defined $self->{__DBH}{$name} );

    # See if a handle is being passed in directly.
    require UNIVERSAL;
    if( ref($_[0]) eq 'ARRAY' or ref $_[0] eq 'CODE' ) {
        $self->{__DBH_CONFIG}{$name} = shift;
    }
    elsif( ref($_[0]) and $_[0]->isa('DBI::db') ) {
        $self->{__DBH}{$name} = shift;

        # Set this to note that we have completed the 'config' stage.
        $self->{__DBH_CONFIG}{$name} = 1;
    }
    else {
        $self->{__DBH_CONFIG}{$name} = \@_;
    }

}

sub __auto_config {
    # get parameters for dbh_config from CGI::App instance parameters
     my $app = shift;
     my $name = shift;


     my $params = $app->param('::Plugin::DBH::dbh_config');
     return __auto_config_env($app, $name) unless $params;

     # if array reference: only one handle configured, pass array contents to dbh_config
     if (UNIVERSAL::isa($params, 'ARRAY')){
        # verify that we really want the default handle
        return unless $name eq dbh_default_name($app);
        dbh_config($app, @$params);
        return;
     }

     # if hash reference: many handles configured, named with the hash keys
     if (UNIVERSAL::isa($params, 'HASH')){
        $params = $params->{$name};
        return __auto_config_env($app, $name) unless $params;
        dbh_config($app, $name, $params);
        return;
     }

    croak "Parameter ::Plugin::DBH::dbh_config must be an array or hash reference";
}

sub __auto_config_env{
    # check if DBI environment variable is set
    # this can be used to configure the default handle
    my $app = shift;
    my $name = shift;

    return unless $name eq dbh_default_name($app);
    return unless $ENV{DBI_DSN};
    # DBI_DSN is set, so autoconfigure with all DSN, user id, pass all undefined
    dbh_config($app, undef, undef, undef);
}

sub dbh_default_name {
    my $self = shift;
    my $old_name = $self->{__DBH_DEFAULT_NAME} || "__cgi_application_plugin_dbh"; # Possible first use case.
    $self->{__DBH_DEFAULT_NAME} = shift if $_[0];
    return $old_name;
}

1;

__END__