[ABE.pm] subclassing the DBI

Phil Lawrence phil at five-lawrences.com
Mon Jun 12 04:56:45 PDT 2006


On Jun 11, 2006, at 10:51 PM, Phil Lawrence wrote:

>
> 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.

Never mind that.  I found my version controlled copy.  Here was my  
latest revision:

package DBIx::DLM;
@DBIx::DLM::ISA = qw(DBI);

use strict;
use diagnostics;

sub dlm_connect
{
	# reference ./t/subclass.t in the DBI install directory for the basic
	# example of subclassing the DBI.

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

	my $parm_href = shift || {};

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

	# get default dbh
	my $dbh = $class->SUPER::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_href->{$_} };
			$dbh->trace( "Warning: $@") if $@;
		}
	}

	return $dbh;
}


package DBIx::DLM::dr;
@DBIx::DLM::dr::ISA = qw(DBI::dr);

sub connect {
	my ($drh, $dsn, $user, $pass, $attr) = @_;
	my $dbh = $drh->SUPER::connect($dsn, $user, $pass, $attr);
	#delete $attr->{CompatMode}; # to test clone
	return $dbh;
}

package DBIx::DLM::db;
@DBIx::DLM::db::ISA = qw(DBI::db);

use File::Basename;
use File::Spec;
use Cwd;
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 $self->SUPER::selectall_hashref( $statement, $key_field,  
undef, @_ );
}

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;
	$remaining = '' unless defined $remaining;

	my @tables = split /,/, $from;
	for (@tables)
	{
		# remove any whitespace residual from splitting
		s/\s+//;
		# these are, of course, filenames

		my ($name,$path,$suffix) = fileparse( $_, qr/\W.+/ );
		$path = File::Spec->canonpath( cwd() ) unless $path;

		for (File::Spec->join($path,($name . $suffix)))
		{
			die "$_ not a valid filename" unless -f;
		}

		$parm_href->{table}{$name}{_pns}{path} = $path;
		$parm_href->{table}{$name}{_pns}{suffix} = defined $suffix
		                                         ? $suffix
		                                         : ''
		                                         ;

		# use slimmed-down table name
		$_ = $name;
	}

	# 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}})
	{
		$self->{'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 might jam into
			# $parm_href and those things the invocant
			# has passed along.
			next if ref $parm_href->{table}{$_}{$attr};

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

	}

	return $self;
}


#======================================================================= 
========
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;






More information about the ABE-pm mailing list