diff options
Diffstat (limited to 't/31methcache.t')
-rw-r--r-- | t/31methcache.t | 153 |
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; |