Author: timbo
Date: Tue Mar 29 03:28:23 2005
New Revision: 940
Modified:
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/t/11fetch.t
dbi/trunk/t/70callbacks.t
Log:
Callbacks invoked with local $_ = method_name
Callbacks are passed all parameters of corresponding method call.
Special case "connect" callback removed, added "connect_cached.new" special
case.
Added tests.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Tue Mar 29 03:28:23 2005
@@ -652,12 +652,6 @@
# if we've been subclassed then let the subclass know that we're
connected
$dbh->connected($dsn, $user, $pass, $attr) if ref $dbh ne 'DBI::db';
- # If the caller has provided a callback then call it
- if (my $cb = $dbh->{Callbacks}) { # take care not to autovivify
- $cb = $cb->{connect};
- $cb->($dbh, $dsn, $user, $pass, $attr) if $cb;
- }
-
DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug;
return $dbh;
@@ -1410,14 +1404,22 @@
join "~~", $dsn, $user||'', $auth||'', $attr ? (@attr_keys,@[EMAIL
PROTECTED]) : ()
};
my $dbh = $cache->{$key};
+ my $cb = $attr->{Callbacks}; # take care not to autovivify
if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) {
# If the caller has provided a callback then call it
- if (my $cb = $dbh->{Callbacks}) { # take care not to autovivify
- $cb = $cb->{"connect_cached.reused"};
- $cb->($dbh, $dsn, $user, $auth, $attr) if $cb;
+ if ($cb and $cb = $cb->{"connect_cached.reused"}) {
+ local $_ = "connect_cached.reused";
+ $cb->($dbh, $dsn, $user, $auth, $attr);
}
return $dbh;
}
+
+ # If the caller has provided a callback then call it
+ if ($cb and $cb = $cb->{"connect_cached.new"}) {
+ local $_ = "connect_cached.new";
+ $cb->($dbh, $dsn, $user, $auth, $attr);
+ }
+
$dbh = $drh->connect(@_);
$cache->{$key} = $dbh; # replace prev entry, even if connect failed
return $dbh;
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue Mar 29 03:28:23 2005
@@ -2408,18 +2408,28 @@
&& (hook_svp = hv_fetch((HV*)SvRV(*hook_svp), meth_name,
strlen(meth_name), 0))
&& SvROK(*hook_svp)
) {
- dSP;
SV *code = SvRV(*hook_svp);
+ I32 count;
if (trace_level)
PerlIO_printf(DBILOGFP, "%c {{ %s callback %s being invoked\n",
(dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0));
+ ENTER;
+ SAVETMPS;
+ EXTEND(SP, items+1);
PUSHMARK(SP);
- XPUSHs(h);
- /* XXX add more params */
+ PUSHs(h); /* push inner handle, then others
params */
+ for (i=1; i < items; ++i) { /* start at 1 to skip handle */
+ PUSHs( ST(i) );
+ }
PUTBACK;
- if (call_sv(code, G_ARRAY))
- die("Callback for %s must not return any values (temporary
restriction in current version)");
+ SAVE_DEFSV; /* local($_) = $method_name */
+ DEFSV = sv_2mortal(newSVpv(meth_name,0));
+ count = call_sv(code, G_ARRAY);
+ if (count != 0)
+ die("Callback for %s returned %d values but must not return any
(temporary restriction in current version)", meth_name, count);
SPAGAIN;
+ FREETMPS;
+ LEAVE;
if (trace_level)
PerlIO_printf(DBILOGFP, "%c }} %s callback %s returned\n",
(dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0));
Modified: dbi/trunk/t/11fetch.t
==============================================================================
--- dbi/trunk/t/11fetch.t (original)
+++ dbi/trunk/t/11fetch.t Tue Mar 29 03:28:23 2005
@@ -104,4 +104,4 @@
}
-# end
+1; # end
Modified: dbi/trunk/t/70callbacks.t
==============================================================================
--- dbi/trunk/t/70callbacks.t (original)
+++ dbi/trunk/t/70callbacks.t Tue Mar 29 03:28:23 2005
@@ -1,4 +1,5 @@
#!perl -w
+# vim:ts=8:sw=4
use strict;
@@ -8,7 +9,7 @@
BEGIN {
plan skip_all => '$h->{Callbacks} attribute not supported for
DBI::PurePerl'
if $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo
warning
- plan tests => 24;
+ plan tests => 35;
}
$| = 1;
@@ -25,13 +26,43 @@
$dbh->{Callbacks} = undef;
is $dbh->{Callbacks}, undef, "Callbacks set to undef again";
-ok $dbh->{Callbacks} = { ping => sub { $called{ping}++; return; } };
-is keys %{ $dbh->{Callbacks} }, 1;
+ok $dbh->{Callbacks} = {
+ ping => sub {
+ is $_, 'ping', '$_ holds method name';
+ $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 };
+ is $_, 'quote_identifier', '$_ holds method name';
+ $called{$_}++;
+ return (1,2,3); # return something
+ },
+};
+is keys %{ $dbh->{Callbacks} }, 2;
+
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;
+
+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!';
+
$dbh->{Callbacks} = undef;
ok $dbh->ping;
is $called{ping}, 2;
@@ -39,12 +70,12 @@
=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
+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
-cumbersom for the user and then it would apply to all future connects
+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"
@@ -55,21 +86,22 @@
my @args = (
$dsn, '', '', {
Callbacks => {
- connect => sub { $called{connect}++; return; },
+ "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 $called{connect}, 1, "Connect callback called once.";
-is $called{cached}, undef, "Cached not yet called";
+is keys %called, 0, 'no callback for plain connect';
ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks";
-is $called{connect}, 2, "Connect callback called by connect_cached.";
-is $called{cached}, undef, "Cached still not yet called";
+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{connect}, 3, "Connect callback called by second connect_cached.";
-is $called{cached}, 1, "Cached called";
+is $called{cached}, 1, "connect_cached.reused called";
+is $called{new}, 1, "connect_cached.new not called again";
