[ABE.pm] subclassing the DBI

[Phil Lawrence]

On May 22, 2006, at 9:09 PM, Faber J. Fedor wrote:
> ... What I was trying to do was to build on the $self
> object, i.e. my base class defines $self->{date}, $self->{template},
> etc. which all of the derived classes need.  Then each derived class
> adds to $self the variables the derived class needs.  This way I don't
> need to call '$dbh = get_dbh()' in every function that needs to do
> a SQL
> stmt (which are quite a few).

OK, I found an example of subclassing the DBI.  Read the comments in  
the connect method below.

package DBIx::DLM;
use strict;
use diagnostics;

use base DBI;
use File::Basename;
use DBD::CSV;

sub selectall_hashref
{
	my $self = shift;

	my $statement = shift or die;
	my $key_field = shift or die;

	# adjust self as necessary   :-)
         $self->_adjust( \$statement, shift() );

	return $dbh->selectall_hashref( $statement, $key_field, undef, @_ );
}

sub connect
{
	# Note that other classes may inherit and use this method only if  
they also
	# subclass DBIx::DLM::db and DBIx::DLM::st in the same manner that  
DBIx::DLM
	# subclasses DBI::db and DBI::st.  See ./t/subclass.t in the DBI  
install
	# directory for the basic example of subclassing the DBI from which  
this
	# module was modelled.

	my $proto = shift;
	my $class = ref($proto) || $proto;

	# Tell the DBI that $class is a new 'root class'.  This enables DBI to
	# bless our object for us.  In other words, the constructor for our  
class
	# is in the DBI package!
	$class->init_rootclass;

	my $parm_href = shift;

	# set defaults, unless invocant has alreay set them
	#   (see perldoc DBD::CSV for all possible attrs)
	for
	(
	  [ 'eol'              => "\n"      ]
	, [ 'sep_char'         => "\t"      ]
	, [ 'quote_char'       => undef     ]
	, [ 'escape_char'      => undef     ]
	, [ 'FetchHashKeyName' => undef     ]
	)
	{
		unless (defined $parm_href->{$_[0]})
		{
			$parm_href->{$_[0]} = $_[1] if defined $_[1];
		}
	}	

	# get default dbh
	my $dbh = $class->connect('DBI:CSV:');

	# turn on the trace first, if so requested
	if (defined $parm_href->{trace})
	{
		$dbh->trace( $parm_href->{trace} );
	}

	# use any $parm key/value pairs (with scalar values) to set dbh  
defaults
	for (keys %{$parm_href})
	{
		# already took care of tracing
		next if /trace/;

		unless (ref $parm_href->{$_})
		{
			# since we'll blindly try any attr, we'll
			# catch errors and just put them in the
			# trace, then move on
			eval { $dbh->{$_} = $parm->{$_} };
			$dbh->trace( "Warning: $@") if $@;
		}
	}

	return $dbh;
}

sub _adjust
{
	my $self = shift;

	my $statement = ${ shift };
	my $parm_href = shift;

	my ($select, $remaining) = split /FROM/i, $statement;
	(my $from, $remaining) = split /WHERE/i, $remaining;

	my @tables = split /,/, $from;
	for (@tables)
	{
		# if any unusual characters
		if (/\W/)
		{
			die "$_ not valid filename" unless (-f $_);

			my ($name,$path,$suffix) = fileparse( $_, qr/\W.+/ );
			die unless defined $name;
			$parm_href->{table}{$name}{_pns}{path} = defined $path
			                                       ? $path
			                                       : ''
			                                       ;
			$parm_href->{table}{$name}{_pns}{suffix} = defined $suffix
			                                         ? $suffix
			                                         : ''
			                                         ;

			# use slimmed-down table name
			$_ = $name;
		}
		else
		{
			$parm->{table}{$_}{_pns}{path} = '';
			$parm->{table}{$_}{_pns}{suffix} = '';
		}
	}

	# rebuild $statement with slimmed-down table names, instead of whatever
	# was passed in (e.g. filenames with path)
	$statement = $select . 'FROM' . join(',', at tables) . $remaining;

	# override dbh defaults on a per table basis
	for (keys %{$parm_href->{table}})
	{
		$dbh->{'csv_tables'}{$_}{file} = $parm_href->{table}{$_}{_pns}{path}
		                               . $_
		                               . $parm_href->{table}{$_}{_pns}{suffix}
		                               ;

		# any of these default attrs may be overridden by invocant
		for my $attr ($parm_href->{table}{$_})
		{
			# only non-ref attributes can be set.  This
			# distinguishes from the stuff we jam into
			# $parm_href and those things the invocant
			# has passed along.
			next if ref $parm_href->{table}{$_}{$attr};

			$dbh->{'csv_tables'}{$_}{$attr} = $parm_href->{table}{$_}{$attr}
                           unless defined $dbh->{'csv_tables'}{$_} 
{$attr};
		}

	}

	return $dbh;
}


#======================================================================= 
========
package DBIx::DLM::db;
use DBI;
use vars qw( @ISA );
push @ISA, 'DBI::db';


#======================================================================= 
========
package DBIx::DLM::st;
use DBI;
use vars qw( @ISA );
push @ISA, 'DBI::st';

1;