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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
#!perl -w
# vim:ts=8:sw=4
use strict;
use Test::More;
use DBI;
BEGIN {
plan skip_all => '$h->{Callbacks} attribute not supported for DBI::PurePerl'
if $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo warning
plan tests => 63;
}
$| = 1;
my $dsn = "dbi:ExampleP:";
my %called;
ok my $dbh = DBI->connect($dsn, '', ''), "Create dbh";
is $dbh->{Callbacks}, undef, "Callbacks initially undef";
ok $dbh->{Callbacks} = my $cb = { };
is ref $dbh->{Callbacks}, 'HASH', "Callbacks can be set to a hash ref";
is $dbh->{Callbacks}, $cb, "Callbacks set to same hash ref";
$dbh->{Callbacks} = undef;
is $dbh->{Callbacks}, undef, "Callbacks set to undef again";
ok $dbh->{Callbacks} = {
ping => sub {
is $_, 'ping', '$_ holds method name';
is @_, 1, '@_ holds 1 values';
is ref $_[0], 'DBI::db', 'first is $dbh';
$called{$_}++;
return;
},
quote_identifier => sub {
is @_, 4, '@_ holds 4 values';
my $dbh = shift;
is ref $dbh, 'DBI::db', 'first is $dbh';
is $_[0], 'foo';
is $_[1], 'bar';
is $_[2], undef;
$_[2] = { baz => 1 };
$called{$_}++;
return (1,2,3); # return something - which is not allowed
},
disconnect => sub { # test die from within a callback
die "You can't disconnect that easily!\n";
},
"*" => sub {
$called{$_}++;
return;
}
};
is keys %{ $dbh->{Callbacks} }, 4;
is ref $dbh->{Callbacks}->{ping}, 'CODE';
$_ = 42;
ok $dbh->ping;
is $called{ping}, 1;
is $_, 42, '$_ not altered by callback';
ok $dbh->ping;
is $called{ping}, 2;
ok $dbh->type_info_all;
is $called{type_info_all}, 1, 'fallback callback';
my $attr;
eval { $dbh->quote_identifier('foo','bar', $attr) };
is $called{quote_identifier}, 1;
ok $@, 'quote_identifier callback caused fatal error';
is ref $attr, 'HASH', 'param modified by callback - not recommended!';
ok !eval { $dbh->disconnect };
ok $@, "You can't disconnect that easily!\n";
$dbh->{Callbacks} = undef;
ok $dbh->ping;
is $called{ping}, 2; # no change
# --- test skipping dispatch and fallback callbacks
$dbh->{Callbacks} = {
ping => sub {
undef $_; # tell dispatch to not call the method
return "42 bells";
},
data_sources => sub {
my ($h, $values_to_return) = @_;
undef $_; # tell dispatch to not call the method
my @ret = 11..10+($values_to_return||0);
return @ret;
},
commit => sub { # test using set_err within a callback
my $h = shift;
undef $_; # tell dispatch to not call the method
return $h->set_err(42, "faked commit failure");
},
};
# these tests are slightly convoluted because messing with the stack is bad for
# your mental health
my $rv = $dbh->ping;
is $rv, "42 bells";
my @rv = $dbh->ping;
is scalar @rv, 1, 'should return a single value in list context';
is "@rv", "42 bells";
# test returning lists with different number of args to test
# the stack handling in the dispatch code
is join(":", $dbh->data_sources()), "";
is join(":", $dbh->data_sources(0)), "";
is join(":", $dbh->data_sources(1)), "11";
is join(":", $dbh->data_sources(2)), "11:12";
{
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
is eval { $dbh->commit }, undef, 'intercepted commit should return undef';
like $@, '/DBD::\w+::db commit failed: faked commit failure/';
is $DBI::err, 42;
is $DBI::errstr, "faked commit failure";
}
# --- test connect_cached.*
=for comment XXX
The big problem here is that conceptually the Callbacks attribute
is applied to the $dbh _during_ the $drh->connect() call, so you can't
set a callback on "connect" on the $dbh because connect isn't called
on the dbh, but on the $drh.
So a "connect" callback would have to be defined on the $drh, but that's
cumbersome for the user and then it would apply to all future connects
using that driver.
The best thing to do is probably to special-case "connect", "connect_cached"
and (the already special-case) "connect_cached.reused".
=cut
my @args = (
$dsn, '', '', {
Callbacks => {
"connect_cached.new" => sub { $called{new}++; return; },
"connect_cached.reused" => sub { $called{cached}++; return; },
}
}
);
%called = ();
ok $dbh = DBI->connect(@args), "Create handle with callbacks";
is keys %called, 0, 'no callback for plain connect';
ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks";
is $called{new}, 1, "connect_cached.new called";
is $called{cached}, undef, "connect_cached.reused not yet called";
ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks";
is $called{cached}, 1, "connect_cached.reused called";
is $called{new}, 1, "connect_cached.new not called again";
# --- test ChildCallbacks.
%called = ();
$args[-1] = {
Callbacks => my $dbh_callbacks = {
ping => sub { $called{ping}++; return; },
ChildCallbacks => my $sth_callbacks = {
execute => sub { $called{execute}++; return; },
fetch => sub { $called{fetch}++; return; },
}
}
};
ok $dbh = DBI->connect(@args), "Create handle with ChildCallbacks";
ok $dbh->ping, 'Ping';
is $called{ping}, 1, 'Ping callback should have been called';
ok my $sth = $dbh->prepare('SELECT name from t'), 'Prepare a statement handle (child)';
ok $sth->{Callbacks}, 'child should have Callbacks';
is $sth->{Callbacks}, $sth_callbacks, "child Callbacks should be ChildCallbacks of parent"
or diag "(dbh Callbacks is $dbh_callbacks)";
ok $sth->execute, 'Execute';
is $called{execute}, 1, 'Execute callback should have been called';
ok $sth->fetch, 'Fetch';
is $called{fetch}, 1, 'Fetch callback should have been called';
__END__
A generic 'transparent' callback looks like this:
(this assumes only scalar context will be used)
sub {
my $h = shift;
return if our $avoid_deep_recursion->{"$h $_"}++;
my $this = $h->$_(@_);
undef $_; # tell DBI not to call original method
return $this; # tell DBI to return this instead
};
XXX should add a test for this
XXX even better would be to run chunks of the test suite with that as a '*' callback. In theory everything should pass (except this test file, naturally)..
|
