#!perl -w
#
# check that the inner-method lookup cache works
# (or rather, check that it doesn't cache things when it shouldn't)
BEGIN { eval "use threads;" } # Must be first
my $use_threads_err = $@;
use Config qw(%Config);
# With this test code and threads, 5.8.1 has issues with freeing freed
# scalars, while 5.8.9 doesn't; I don't know about in-between - DAPM
my $has_threads = $Config{useithreads};
die $use_threads_err if $has_threads && $use_threads_err;
use strict;
$|=1;
$^W=1;
use Test::More tests => 49;
BEGIN {
use_ok( 'DBI' );
}
sub new_handle {
my $dbh = DBI->connect("dbi:Sponge:foo","","", {
PrintError => 0,
RaiseError => 1,
});
my $sth = $dbh->prepare("foo",
# data for DBD::Sponge to return via fetch
{ rows =>
[
[ "row0" ],
[ "row1" ],
[ "row2" ],
[ "row3" ],
[ "row4" ],
[ "row5" ],
[ "row6" ],
],
}
);
return ($dbh, $sth);
}
sub Foo::local1 { [ "local1" ] };
sub Foo::local2 { [ "local2" ] };
my $fetch_hook;
{
package Bar;
@Bar::ISA = qw(DBD::_::st);
sub fetch { &$fetch_hook };
}
sub run_tests {
my ($desc, $dbh, $sth) = @_;
my $row = $sth->fetch;
is($row->[0], "row0", "$desc row0");
{
# replace CV slot
no warnings 'redefine';
local *DBD::Sponge::st::fetch = sub { [ "local0" ] };
$row = $sth->fetch;
is($row->[0], "local0", "$desc local0");
}
$row = $sth->fetch;
is($row->[0], "row1", "$desc row1");
{
# replace GP
local *DBD::Sponge::st::fetch = *Foo::local1;
$row = $sth->fetch;
is($row->[0], "local1", "$desc local1");
}
$row = $sth->fetch;
is($row->[0], "row2", "$desc row2");
{
# replace GV
local $DBD::Sponge::st::{fetch} = *Foo::local2;
$row = $sth->fetch;
is($row->[0], "local2", "$desc local2");
}
$row = $sth->fetch;
is($row->[0], "row3", "$desc row3");
{
# @ISA = NoSuchPackage
local $DBD::Sponge::st::{fetch};
local @DBD::Sponge::st::ISA = qw(NoSuchPackage);
eval { local $SIG{__WARN__} = sub {}; $row = $sth->fetch };
like($@, qr/Can't locate DBI object method/, "$desc locate DBI object");
}
$row = $sth->fetch;
is($row->[0], "row4", "$desc row4");
{
# @ISA = Bar
$fetch_hook = \&DBD::Sponge::st::fetch;
local $DBD::Sponge::st::{fetch};
local @DBD::Sponge::st::ISA = qw(Bar);
$row = $sth->fetch;
is($row->[0], "row5", "$desc row5");
$fetch_hook = sub { [ "local3" ] };
$row = $sth->fetch;
is($row->[0], "local3", "$desc local3");
}
$row = $sth->fetch;
is($row->[0], "row6", "$desc row6");
}
run_tests("plain", new_handle());
SKIP: {
skip "no threads / perl < 5.8.9", 12 unless $has_threads;
# only enable this when handles are allowed to be shared across threads
#{
# my @h = new_handle();
# threads->new(sub { run_tests("threads", @h) })->join;
#}
threads->new(sub { run_tests("threads-h", new_handle()) })->join;
};
# using weaken attaches magic to the CV; see whether this interferes
# with the cache magic
use Scalar::Util qw(weaken);
my $fetch_ref = \&DBI::st::fetch;
weaken $fetch_ref;
run_tests("magic", new_handle());
SKIP: {
skip "no threads / perl < 5.8.9", 12 unless $has_threads;
# only enable this when handles are allowed to be shared across threads
#{
# my @h = new_handle();
# threads->new(sub { run_tests("threads", @h) })->join;
#}
threads->new(sub { run_tests("magic threads-h", new_handle()) })->join;
};
1;