File Coverage

blib/lib/Template/Plugin/DBI.pm

Criterion	Covered	Total	%
statement	154	225	68.4
branch	43	88	48.8
condition	29	78	37.1
subroutine	33	43	76.7
pod	12	13	92.3
total	271	447	60.6

#==============================================================================
#
# Template::Plugin::DBI
#
# DESCRIPTION
#   A Template Toolkit plugin to provide access to a DBI data source.
#
# AUTHORS
#   Original version by Simon Matthews
#   with some reworking by Andy Wardley  and other
#   contributions from Craig Barratt ,
#   Dave Hodgkinson  and Rafael Kitover
#   .
#   Since 2010 Jens Rehsack  maintains this module.
#
# COPYRIGHT
#   Copyright (C) 1999-2000 Simon Matthews.  All Rights Reserved.
#   Copyright (C) 2006 Andy Wardley.  All Rights Reserved.
#   Copyright (C) 2010 Jens Rehsack.  All Rights Reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
# REVISION
#   $Id$
#
#==============================================================================

package Template::Plugin::DBI;

use strict;
use warnings;

use Carp qw(croak carp);
use DBI;

use Template::Exception;
use base 'Template::Plugin';

our $VERSION  = 2.65;
our $DEBUG    = 0 unless defined $DEBUG;
our $QUERY    = 'Template::Plugin::DBI::Query';
our $ITERATOR = 'Template::Plugin::DBI::Iterator';

my $threads_enabled = 0;
my $have_tvr        = 0;

BEGIN
{
    $INC{"threads.pm"} and eval {
        ++$threads_enabled;
        require threads::variable::reap;
        ++$have_tvr;
    };

    $have_tvr
      and threads::variable::reap->import(qw(reap reapref));
}

# alias _connect() to connect() for backwards compatability
*_connect = \*connect;

#------------------------------------------------------------------------
# new($context, @params)
#
# Constructor which returns a reference to a new DBI plugin object.
# A connection string (dsn), user name and password may be passed as
# positional arguments or a hash array of connection parameters can be
# passed to initialise a connection.  Otherwise, an unconnected DBI
# plugin object is returned.
#------------------------------------------------------------------------

sub new
{
    my ( $class, $context, @connect_args ) = @_;
    my $self =
      ref $class
      ? $class
      : bless {
                _CONTEXT => $context,
                _STH     => undef,
              }, $class;

    $self->connect(@connect_args) if @connect_args;

    return $self;
}

#------------------------------------------------------------------------
# connect( $data_source, $username, $password, $attributes )
# connect( { data_source => 'dbi:driver:database'
#	     username    => 'foo'
#	     password    => 'bar' } )
#
# Opens a DBI connection for the plugin.
#------------------------------------------------------------------------

sub connect
{
    my $self = shift;
    my $params = ref $_[-1] eq 'HASH' ? pop(@_) : {};
    my ( $dbh, $dsn, $user, $pass, $klobs );

    # set debug flag
    exists $params->{debug} and $DEBUG = $params->{debug};
    $self->{_DEBUG} = $params->{debug} || 0;

    # fetch 'dbh' named paramater or use positional arguments or named
    # parameters to specify 'dsn', 'user' and 'pass'

    if ( $dbh = $params->{dbh} )
    {
        # disconnect any existing database handle that we previously opened
        $self->{_DBH}->disconnect()
          if $self->{_DBH} && $self->{_DBH_CONNECT};

        # store new dbh but leave _DBH_CONNECT false to prevent us
        # from automatically closing it in the future
        $self->{_DBH}         = $dbh;
        $self->{_DBH_CONNECT} = 0;
    }
    else
    {
        # certain Perl programmers are known to have problems with short
        # term memory loss (see Tie::Hash::Cannabinol) so we let the poor
        # blighters fumble any kind of argument that looks like it might
        # identify the database

        $dsn =
             shift
          || delete $params->{data_source}
          || delete $params->{database}
          || delete $params->{connect}
          || delete $params->{dsn}
          || delete $params->{db}
          || delete $self->{_DSN}
          || $ENV{DBI_DSN}
          || return $self->_throw('data source not defined');

        # add 'dbi:' prefix if it's not there
        $dsn = "dbi:$dsn" unless $dsn =~ /^dbi:/i;

        $user =
             shift
          || delete $params->{username}
          || delete $params->{user}
          || delete $self->{_USER};

        $pass =
             shift
          || delete $params->{password}
          || delete $params->{pass}
          || delete $self->{_PASS};

        $user ||= '';
        $pass ||= '';

        # save connection data because we might need it later to do a tie()
        @$self{qw( _DSN _USER _PASS )} = ( $dsn, $user, $pass );

        # reuse existing database handle if connection params match
        my $connect = join( ':', $dsn, $user, $pass );
        return ''
          if $self->connected() && $self->{_DBH_CONNECT} eq $connect;

        # otherwise disconnect any existing database handle that we opened
        $self->disconnect();

        # don't need DBI to automatically print errors because all calls go
        # via this plugin interface and we always check return values
        $params->{PrintError} = 0
          unless defined $params->{PrintError};
        $params->{RaiseError} = 0
          unless defined $params->{RaiseError};

        $self->{_DBH} = DBI->connect_cached( $dsn, $user, $pass, $params )
          || return $self->_throw("DBI connect failed: $DBI::errstr");

        # store the connection parameters
        $self->{_DBH_CONNECT} = $connect;
    }

    $have_tvr
      and reap( $self->{_DBH} )
      and reap( $self->{_STH} );

    return '';
}

sub connected
{
    my $self = $_[0];
    return $self->{_DBH} && $self->{_DBH}->isa('DBI::db');
}

#------------------------------------------------------------------------
# disconnect()
#
# Disconnects the current active database connection.
#------------------------------------------------------------------------

sub disconnect
{
    my $self = $_[0];
    delete( $self->{_STH} );    # first DESTROY any queries
    $self->connected() and $self->{_DBH}->disconnect();
    delete $self->{_DBH};
    delete $self->{_DSN};
    delete $self->{_USER};
    delete $self->{_PASS};
    delete $self->{_DBH_CONNECT};
    return '';
}

#------------------------------------------------------------------------
# tie( $table, $key )
#
# Return a hash tied to a table in the database, indexed by the specified
# key.
#------------------------------------------------------------------------

sub tie
{
    my $self = shift;
    my $params = ref $_[-1] eq 'HASH' ? pop(@_) : {};
    my ( $table, $key, $klobs, $debug, %hash );

    eval { require Tie::DBI };
    $self->_throw("failed to load Tie::DBI module: $@") if $@;

    $table =
         shift
      || $params->{table}
      || $self->_throw('table not defined');

    $key =
         shift
      || $params->{key}
      || $self->_throw('key not defined');

    # Achtung der Klobberman!
    $klobs = $params->{clobber};
    $klobs = $params->{CLOBBER} unless defined $klobs;

    # going the extra mile to allow user to use UPPER or lower case or
    # inherit internel debug flag set by connect()
    $debug = $params->{debug};
    $debug = $params->{DEBUG} unless defined $debug;
    $debug = $self->{_DEBUG} unless defined $debug;

    tie %hash, 'Tie::DBI', {
        %$params,    # any other Tie::DBI options like DEBUG, WARN, etc
        db => $self->{_DBH} || $self->{_DSN},
        user     => $self->{_USER},
        password => $self->{_PASS},
        table    => $table,
        key      => $key,
        CLOBBER  => $klobs || 0,
        DEBUG    => $debug || 0,
                           };

    return \%hash;
}

#------------------------------------------------------------------------
# prepare($sql)
#
# Prepare a query and store the live statement handle internally for
# subsequent execute() calls.
#------------------------------------------------------------------------

sub prepare
{
    my ($self,@args) = @_;
    unless( @args and $args[0] and "" eq ref($args[0]) )
    {
	return $self->_throw("prepare called without statement");
    }

    my $sth = $self->dbh()->prepare(@args)
      || return $self->_throw( "DBI prepare failed: " . $self->dbh()->errstr );

    # create wrapper object around handle to return to template client
    $sth = $QUERY->new($sth);
    $self->{_STH} = $sth;

    return $sth;
}

#------------------------------------------------------------------------
# execute()
#
# Calls execute() on the most recent statement created via prepare().
#------------------------------------------------------------------------

sub execute
{
    my $self = shift;
    my @args = @_ == 1 && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;

    my $sth = $self->{_STH}
      || return $self->_throw('no query prepared');

    $sth->execute(@args);
}

#------------------------------------------------------------------------
# query($sql, @params)
#
# Prepares and executes a SQL query.
#------------------------------------------------------------------------

sub query
{
    my ( $self, $sql, @args ) = @_;
    my @prep = ($sql);

    if( @args and $args[0] and ref($args[0]) eq 'HASH' )
    {
	push(@prep, shift @args);
    }

    return $self->prepare(@prep)->execute(@args);
}

#------------------------------------------------------------------------
# do($sql, \%attr, @bind)
#
# Prepares and executes a SQL statement.
#------------------------------------------------------------------------

sub do
{
    my $self = shift;
    my @args = @_ == 1 && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;

    return $self->dbh()->do(@args)
      || $self->_throw( "DBI do failed: " . $self->dbh()->errstr );
}

#------------------------------------------------------------------------
# quote($value [, $data_type ])
#
# Returns a quoted string (correct for the connected database) from the
# value passed in.
#------------------------------------------------------------------------

sub quote
{
    my ( $self, @quote_args ) = @_;
    return $self->dbh()->quote(@quote_args);
}

#------------------------------------------------------------------------
# dbh()
#
# Internal method to retrieve the database handle belonging to the
# instance or attempt to create a new one using connect.
#------------------------------------------------------------------------

sub dbh
{
    my $self = $_[0];

    $self->{_DBH} or $self->connect;

    return $self->{_DBH};
}

#------------------------------------------------------------------------
# DESTROY
#
# Called automatically when the plugin object goes out of scope to
# disconnect the database handle cleanly
#------------------------------------------------------------------------

sub DESTROY
{
    my $self = $_[0];
    delete( $self->{_STH} );    # first DESTROY any queries
    $self->{_DBH}->disconnect()
      if ( $self->connected() && $self->{_DBH_CONNECT} );
}

#------------------------------------------------------------------------
# _throw($error)
#
# Raise an error by throwing it via die() as a Template::Exception
# object of type 'DBI'.
#------------------------------------------------------------------------

sub _throw
{
    my $self = shift;
    my $error = shift || croak "DBI throw() called without an error string";

    # throw error as DBI exception
    die( Template::Exception->new( 'DBI', $error ) );
}

sub fetch
{
    my ( $self, $attr ) = @_;

    return $self->_throw("Cannot fetch attribute on not connected \$dbh") unless ( $self->connected() );

    my $dbh = $_[0]->{_DBH};
    local $@ = undef;
    my $value;
    eval { $value = $dbh->{$attr}; };
    return $self->_throw($@) if ($@);

    return $value;
}

sub store
{
    my ( $self, $attr, $value ) = @_;

    return $self->_throw("Cannot store attribute on not connected \$dbh") unless ( $self->connected() );

    my $dbh = $_[0]->{_DBH};
    local $@ = undef;
    eval { $dbh->{$attr} = $value; };
    return $self->_throw($@) if ($@);

    return 1;
}

#========================================================================
# Template::Plugin::DBI::Query
#========================================================================

package Template::Plugin::DBI::Query;
use vars qw( $DEBUG $ITERATOR $AUTOLOAD );

use Scalar::Util qw(blessed);

*DEBUG    = \$Template::Plugin::DBI::DEBUG;
*ITERATOR = \$Template::Plugin::DBI::ITERATOR;

sub new
{
    my ( $class, $sth ) = @_;
    my $self = bless( { _STH => $sth }, $class );
}

sub execute
{
    my $self = shift;
    my @args = @_ == 1 && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_;

    $self->{_STH}->execute(@args)
      || return Template::Plugin::DBI->_throw( "execute failed: " . $self->{_STH}->errstr );

    $ITERATOR->new($self);
}

sub DESTROY
{
    undef $_[0]->{_STH};
}

sub AUTOLOAD
{
    my ( $self, @args ) = @_;

    die Template::Exception->new( 'DBI', "$self is not an object" ) unless ( blessed($self) );
    die Template::Exception->new( 'DBI', "No statement handle" ) unless ( defined( $self->{_STH} ) );

    ( my $name = $AUTOLOAD ) =~ s/.*://;
    return $self->{_STH}->$name(@args);
}

#========================================================================
# Template::Plugin::DBI::Iterator;
#========================================================================

package Template::Plugin::DBI::Iterator;

use Template::Iterator;
use base qw( Template::Iterator );
use vars qw( $DEBUG );

*DEBUG = \$Template::Plugin::DBI::DEBUG;

sub new
{
    my ( $class, $sth, $params ) = @_;

    my $rows = $sth->rows();

    my $self = bless {
                       _STH => $sth,
                       SIZE => $rows,
                       MAX  => $rows - 1,
                     }, $class;

    return $self;
}

#------------------------------------------------------------------------
# get_first()
#
# Initialises iterator to read from statement handle.  We maintain a
# one-record lookahead buffer to allow us to detect if the current
# record is the last in the series.
#------------------------------------------------------------------------

sub get_first
{
    my $self = shift;
    $self->{_STARTED} = 1;

    # set some status variables into $self
    @$self{qw(  PREV   ITEM FIRST LAST COUNT INDEX )} = ( undef, undef, 2, 0, 0, -1 );

    # support 'number' as an alias for 'count' for backwards compatability
    $self->{NUMBER} = 0;

    print STDERR "get_first() called\n" if $DEBUG;

    # get the first row
    $self->_fetchrow();

    print STDERR "get_first() calling get_next()\n" if $DEBUG;

    return $self->get_next();
}

#------------------------------------------------------------------------
# get_next()
#
# Called to read remaining result records from statement handle.
#------------------------------------------------------------------------

sub get_next
{
    my $self = shift;
    my ( $data, $fixup );

    # increment the 'index' and 'count' counts
    $self->{INDEX}++;
    $self->{COUNT}++;
    $self->{NUMBER}++;    # 'number' is old name for 'count'

    # decrement the 'first-record' flag
    $self->{FIRST}-- if $self->{FIRST};

    # we should have a row already cache in NEXT
    return ( undef, Template::Constants::STATUS_DONE )
      unless $data = $self->{NEXT};

    # set PREV to be current ITEM from last iteration
    $self->{PREV} = $self->{ITEM};

    # look ahead to the next row so that the rowcache is refilled
    $self->_fetchrow();

    $self->{ITEM} = $data;
    return ( $data, Template::Constants::STATUS_OK );
}

sub get
{
    my $self = shift;
    my ( $data, $error );

    ( $data, $error ) = $self->{_STARTED} ? $self->get_next() : $self->get_first();

    return $data;
}

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

    my $data = $sth->fetchall_arrayref( {} );
    $self->throw( $sth->errstr ) if ( $sth->err() );
    unshift( @$data, $self->{NEXT} ) if $self->{NEXT};
    $self->{LAST} = 1;
    $self->{NEXT} = undef;

    return $data;
}

sub get_colnames
{
    my $self = shift;
    my $sth  = $self->{_STH};
    my $error;

    my $data = $sth->{_STH}->{NAME_lc};
    $self->throw( $sth->errstr ) if ( $sth->err() );

    return $data;
}

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

    my $data = $sth->{_STH}->{NAME_uc};
    $self->throw( $sth->errstr ) if ( $sth->err() );

    return $data;
}

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

    my $data = $sth->fetchall_arrayref();
    $self->throw( $sth->errstr ) if ( $sth->err() );
    if ( $self->{NEXT} )
    {
        my $fetch_hash_key_name = $self->{_STH}->{FetchHashKeyName};
        my @cols                = @{ $self->{_STH}->{$fetch_hash_key_name} };
        my @row                 = @{ $self->{NEXT} }[@cols];
        unshift( @$data, \@row );
    }
    $self->{LAST} = 1;
    $self->{NEXT} = undef;

    return $data;
}

sub rows
{
    return $_[0]->{SIZE};
}

sub fetch
{
    my ( $self, $attr ) = @_;
    $self->{_STH}->FETCH($attr);
}

sub store
{
    my ( $self, $attr, $value ) = @_;
    return $self->{_STH}->STORE( $attr, $value );
}

#------------------------------------------------------------------------
# _fetchrow()
#
# Retrieve a record from the statement handle and store in row cache.
#------------------------------------------------------------------------

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

    my $data = $sth->fetchrow_hashref() || do
    {
        $self->{LAST} = 1;
        $self->{NEXT} = undef;
        return;
    };
    $self->{NEXT} = $data;
    return;
}

1;

__END__