1 files changed, 153 insertions, 0 deletions
diff --git a/t/31methcache.t b/t/31methcache.t
new file mode 100644
index 0000000..2ffd0a5
--- /dev/null
+++ b/t/31methcache.t
@@ -0,0 +1,153 @@
+#!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;