Here's a solution that doesn't use the callback mechanism, so it works with older versions of DBI. To use it, give it as the RootClass to DBI->connect. Since we were already using DBIx::ContextualFetch there, the code below uses that as its base, but it's not otherwise required.
package My::DatabaseRoot;
use strict;
use warnings;
use base 'DBIx::ContextualFetch';
package My::DatabaseRoot::db;
use base 'DBIx::ContextualFetch::db';
sub _rewrite {
return $_[0] if ! defined $_[0];
return $_[0] if $_[0] =~ m{ COMPANY \s DEBUGGING \s INFO }xms;
my $new_req = shift @_;
# Add a newline, if there isn't one.
$new_req =~ s{ ([^\n]) \z }{$1\n}xms;
$new_req .= "/* COMPANY DEBUGGING INFO\n";
my $frame_num = 1;
while ( my @frame_info = caller( $frame_num++ ) ) {
$new_req .= "$frame_num. $frame_info[0]\::$frame_info[3] ($fra
+me_info[1], line $frame_info[2])\n";
}
$new_req .= "*/\n";
return $new_req;
}
my @methods = qw(
do
prepare
prepare_cached
selectrow_array
selectrow_arrayref
selectrow_hashref
selectall_arrayref
selectall_hashref
selectcol_arrayref
);
foreach my $method_name ( @methods ) {
my $method = $method_name;
no strict 'refs';
*{ __PACKAGE__ . "::$method" } = sub {
my $self = shift @_;
my $sql = _rewrite( shift @_ );
return $self->${ \"SUPER::$method" }( $sql, @_ );
};
}
package LT::DatabaseRoot::st;
use base 'DBIx::ContextualFetch::st';
1;
__END__
=pod
=head1 NAME
My::DatabaseRoot -- A class between the application and database
=head1 SYNOPSIS
DBI->connect( $dsn, $user, $pass,
{ RootClass => 'My::DatabaseRoot' } );
=head1 DESCRIPTION
The purpose of My::DatabaseRoot is to get between the application
and the database. Anything we want to do with our DBI access on a
global basis can be added here.
=head1 AUTHOR
Kyle Hasselbacher
=cut