[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