I've written a small proxy wrapper for DBI (included at the bottom of this
email) that walks and talks like a $dbh, but is really a different class. It
is part of a larger set of modules that implement a connection pooling
strategy (it gives me a way to trap DESTROY while also holding a copy of the
real $dbh in my pool for auditing). The proxy works well for all the cases I
have tested except this one:
$dbh = DBI->connect(...);
$proxy = DBIx::Proxy->new($dbh);
$name = $dbh->{Driver}->{Name};
$name = $proxy->{Driver}->{Name};
That last line gives me a "Can't use an undefined value as a HASH reference"
error. Using Data::Dumper on $dbh->{Driver} and $proxy->{Driver} gives me
exactly the same thing. Using Devel::Peek's Dump method, however, shows
something different:
Dump($dbh) -
SV = PVMG(0x92972f0) at 0x9320c84
REFCNT = 1
FLAGS = (TEMP,GMG,SMG,RMG)
IV = 0
NV = 0
PV = 0
MAGIC = 0x931fb48
MG_VIRTUAL = &PL_vtbl_packelem
MG_TYPE = 'p'
MG_FLAGS = 0x02
REFCOUNTED
MG_OBJ = 0x9320b40
SV = RV(0x918f32c) at 0x9320b40
REFCNT = 2
FLAGS = (ROK)
RV = 0x9320ac8
SV = PVHV(0x932de50) at 0x9320ac8
REFCNT = 1
FLAGS = (OBJECT,RMG,SHAREKEYS)
IV = 11
NV = 0
MAGIC = 0x932c610
MG_VIRTUAL = 0
MG_TYPE = '~'
MG_FLAGS = 0x02
REFCOUNTED
MG_OBJ = 0x9320bb8
SV = PVMG(0x92972d0) at 0x9320bb8
REFCNT = 1
FLAGS = (OBJECT)
IV = 0
NV = 0
PV = 0x93350b8 ""
CUR = 0
LEN = 637
STASH = 0x932d8ec "DBD::mysql::db_mem"
STASH = 0x91eff74 "DBI::db"
...
Dump($proxy) -
SV = PVMG(0x92972f0) at 0x9320c84
REFCNT = 1
FLAGS = (TEMP,GMG,SMG,RMG)
IV = 0
NV = 0
PV = 0
MAGIC = 0x931fb48
MG_VIRTUAL = &PL_vtbl_packelem
MG_TYPE = 'p'
MG_FLAGS = 0x02
REFCOUNTED
MG_OBJ = 0x9320c48
SV = RV(0x918f36c) at 0x9320c48
REFCNT = 2
FLAGS = (ROK)
RV = 0x9161f98
SV = PVHV(0x932deb0) at 0x9161f98
REFCNT = 1
FLAGS = (OBJECT,SHAREKEYS)
IV = 2
NV = 0
STASH = 0x9316ef8 "DBIx::ProxyTie"
ARRAY = 0x91efc70 (0:6, 1:2)
...
It looks like the "STASH" is different for the proxy object, but I cannot
for the life of me figure out how that is possible. I tried digging through
the DBI.xs code, and recompiling without "xsbypass" to see if the shortcut
was causing this problem. Didn't have any luck with that approach however.
Here is some output from the little test script with DBI_TRACE set to "4":
$dbh->{Driver}->{Name}:
-> FETCH for DBD::mysql::db (DBI::db=HASH(0x9320ac8)~INNER 'Driver')
.. FETCH DBI::db=HASH(0x9320ac8) 'Driver' = DBI::dr=HASH(0x915f6ec)
<- FETCH= DBI::dr=HASH(0x915f6ec) at proxy.t line 23
<> FETCH= 'mysql' ('Name' from cache) at proxy.t line 23
$proxy->{Driver}->{Name}:
-> FETCH for DBD::mysql::db (DBI::db=HASH(0x9320ac8)~INNER 'Driver')
.. FETCH DBI::db=HASH(0x9320ac8) 'Driver' = DBI::dr=HASH(0x915f6ec)
<- FETCH= DBI::dr=HASH(0x915f6ec) at Proxy.pm line 111 via ./proxy.t
line 31
Can't use an undefined value as a HASH reference at ./proxy.t line 31.
Here is the code for the Proxy classes that I am using:
package DBIx::Proxy;
use strict;
use vars '$AUTOLOAD';
use Scalar::Util qw/refaddr/;
# "inside-out object" stuff here
my %dbh_of;
#-------------------------------------------------------------------------------
sub new {
my ($class,$dbh,$on_destroy) = @_;
# we both tie and bless this object. The tie takes care of things like
# $dbh->{AutoCommit} by forwarding the request down to the dbh from the
# proxy. The bless takes care of forwarding instance methods (using the
# AUTOLOAD method below).
tie my %obj, 'DBIx::ProxyTie', $dbh, $on_destroy;
my $self = bless \%obj, $class;
# initialize our instance variables
$dbh_of{refaddr($self)} = $dbh;
return $self;
}
#-------------------------------------------------------------------------------
sub AUTOLOAD {
my $self = shift;
(my $fn = $AUTOLOAD) =~ s/.*:://;
my $sub = sub {
my $self = shift;
$dbh_of{refaddr($self)}->$fn(@_);
};
{
no strict 'refs';
*$AUTOLOAD = $sub;
}
$sub->($self,@_);
}
#-------------------------------------------------------------------------------
sub DESTROY {
my ($self) = @_;
delete $dbh_of{refaddr($self)};
}
################################################################################
package DBIx::ProxyTie;
use strict;
use Carp;
#-------------------------------------------------------------------------------
sub TIEHASH {
my ($class,$dbh,$on_destroy) = @_;
bless { dbh => $dbh,
on_destroy => $on_destroy }, $class;
}
#-------------------------------------------------------------------------------
sub FETCH {
my ($self,$field) = @_;
return $self->{dbh} if ($field eq 'dbh');
return $self->{dbh}{$field};
}
#-------------------------------------------------------------------------------
sub STORE {
my ($self,$field,$value) = @_;
return $self->{dbh}{$field} = $value;
}
#-------------------------------------------------------------------------------
sub EXISTS {
my ($self,$field) = @_;
return exists($self->{dbh}{$field});
}
#-------------------------------------------------------------------------------
sub DELETE {
my ($self,$field) = @_;
delete $self->{dbh}{$field};
}
#-------------------------------------------------------------------------------
sub CLEAR {
croak "\'= ()\' not supported on Imdb::Util::DBI::ProxyTie";
}
#-------------------------------------------------------------------------------
sub FIRSTKEY {
my ($self) = @_;
keys %{ $self->{dbh} };
my $first_key = each %{ $self->{dbh} };
return undef unless defined $first_key;
return $first_key;
}
#-------------------------------------------------------------------------------
sub NEXTKEY {
my ($self) = @_;
my $next_key = each %{ $self->{dbh} };
return undef unless defined $next_key;
return $next_key;
}
#-------------------------------------------------------------------------------
sub DESTROY {
my ($self) = @_;
print STDERR "ProxyTie->DESTROY\n";
$self->{on_destroy}->($self) if $self->{on_destroy};
}
1;
Major thanks to anyone who can help me figure this one out!
Charles Gordon
