1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
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;
|
