DBIx::AnyDBD and DBI subclassing: do they fit?

[Terrence Brannon]

I am inlining a classic example of DBI subclassing written by 
Stephen Clouse and posted to dbi-users awhile back. My point in 
doing so is to ask how the fact that AnyDBD groks with @ISA would 
affect the $dbh of a straightforward DBI subclass like this...

And how would statement handles be blessed into the developed sth class?


# IQ Group Application Framework
# Version 1.0
#
# Copyright B) 2001 The IQ Group, Inc.  All rights reserved.
#
# $Id: DBI.pm,v 1.4 2001/10/11 00:34:20 stephenc Exp $

package IQGroup::Core::DBI;

use v5.6.1;
use warnings;
use strict;
use Carp;
use DBI;

our $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
our @ISA = qw(DBI);

__PACKAGE__->init_rootclass;

sub connect_cached {
     my $dbh = shift->SUPER::connect_cached(@_);
     return undef unless $dbh;
     $dbh->{private_last_use} = time();
     return $dbh;
}

############################################################

package IQGroup::Core::DBI::db;

use strict;
use Carp;

our @ISA = qw(DBI::db);

sub prepare {
     my($self,$statement,$attr) = @_;
     my $caller = (caller(1))[3] || '';
     my $caller2 = (caller(2))[3] || '';
     return $self->SUPER::prepare($statement,$attr)
        if $caller eq 'DBD::_::db::prepare_cached' # avoid infinite 
loop on callback from DBI
            or $caller2 eq 'DBD::Oracle::db::ping'  # don't cache db 
ping statement -- otherwise it always
                # returns true even if the connection died
                or $statement !~ /^SELECT\b/i; # only cache SELECT statements
     my $st = $self->SUPER::prepare_cached($statement,$attr,1);
     return undef unless $st;
     $st->{private_last_use} = time();
     $st->{private_prepare_count}++;
     return $st;
}

sub prepare_cached { prepare(@_) }

sub cleanup_database_caches {
     my($self) = @_;

   STATEMENTCACHE: {
       my $cache = $self->{CachedKids};
       my %age;
       while (my($key,$st) = each(%$cache)) {
          $age{$key} = [(time() - $st->{private_last_use}), 
$st->{private_prepare_count}];
       }
       my @order = sort {$age{$b}->[0] <=> $age{$a}->[0] || 
$age{$a}->[1] <=> $age{$b}->[1]} keys %age;
       if (@order > 50) {
          splice(@order,-50);
          foreach my $key (@order) {
#my $last = $cache->{$key}->{private_last_use};
#my $age = $age{$key}->[0];
#my $prep = $age{$key}->[1];
#warn("Killing statement handle $key (last use = $last, age = 
$age, prepare count = $prep)");
              delete $cache->{$key};
          }
       }
   }

   DRIVERCACHE: {
       my $cache = $self->{Driver}->{CachedKids};
       while (my($key,$dbh) = each(%$cache)) {
          my $age = time() - $dbh->{private_last_use};
#warn("Killing database handle $key (last use = 
$dbh->{private_last_use}, age = $age)"),
          delete $cache->{$key} if $age > 300;
       }
   }

     return 0;
}

sub GetNextSequenceValue {
     my($self,$seqname) = @_;
     my $st = $self->prepare("SELECT $seqname.nextval FROM dual");
     $st->execute;
     return $st->fetch->[0];
}

sub GetCurrentSequenceValue {
     my($self,$seqname) = @_;
     my $st = $self->prepare('SELECT last_number FROM 
user_sequences WHERE sequence_name = ?');
     $st->execute(uc($seqname));
     my $data = $st->fetch;
     croak "Invalid sequence $seqname" if !$data;
     return $data->[0];
}

sub ResetSequence {
     my($self,$seqname,$value) = @_;
     $self->do("DROP SEQUENCE $seqname");
     $self->do("CREATE SEQUENCE $seqname START WITH $value NOCACHE");
     return 0;
}

sub commit {
     my($self) = @_;
     $self->SUPER::commit;
     return unless $self->{private_post_commit};
     foreach my $class (keys %{$self->{private_post_commit}}) {
        &{$self->{private_post_commit}->{$class}};
        delete $self->{private_post_commit}->{$class};
     }
}

sub RegisterPostCommitSub {
     my($self,$class,$sub_ref) = @_;
     $self->{private_post_commit}->{$class} = $sub_ref;
}

############################################################

package IQGroup::Core::DBI::st;

use strict;
use Carp;

our @ISA = qw(DBI::st);

sub transform {
     my($self,$subref) = @_;
     croak 'Not a subref' if ref($subref) ne 'CODE';
     $self->{private_transform}->{sub} = $subref;
}

sub fetch {
     my($self,@args) = @_;
     my $row = $self->SUPER::fetch(@args);
     return undef unless $row;
     return $row unless $self->{private_transform};
     return $self->{private_transform}->{sub}->($self,$row);
}

1;

__END__

=head1 NAME

IQGroup::Core::DBI - IQ Group Application Framework module

=head1 DESCRIPTION

This is stub documentation.  Move along now.

=cut