Author: timbo
Date: Tue Mar 22 16:20:17 2005
New Revision: 933
Added:
dbi/trunk/t/70callbacks.t
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/DBIXS.h
dbi/trunk/MANIFEST
dbi/trunk/lib/DBI/PurePerl.pm
Log:
Added $h->{Callbacks} attribute to enable code hooks to be invoked
when certain methods are called.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue Mar 22 16:20:17 2005
@@ -4,6 +4,13 @@
=cut
+=head2 Changes in DBI 1.49 (svn rev XXX), 2005
+
+ Added $h->{Callbacks} attribute to enable code hooks to be invoked
+ when certain methods are called. For example:
+ $dbh->{Callbacks}->{prepare} = sub { ... };
+ With thanks to David Wheeler for the kick start.
+
=head2 Changes in DBI 1.48 (svn rev 928), 14th March 2005
Fixed DBI::DBD::Metadata generation of type_info_all thanks to Steffen
Goeldner
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Tue Mar 22 16:20:17 2005
@@ -9,7 +9,7 @@
require 5.006_00;
BEGIN {
-$DBI::VERSION = "1.48"; # ==> ALSO update the version in the pod text below!
+$DBI::VERSION = "1.49"; # ==> ALSO update the version in the pod text below!
}
=head1 NAME
@@ -115,7 +115,7 @@
=head2 NOTES
-This is the DBI specification that corresponds to the DBI version 1.48.
+This is the DBI specification that corresponds to the DBI version 1.49.
The DBI is evolving at a steady pace, so it's good to check that
you have the latest copy.
@@ -652,10 +652,10 @@
# 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
- # especially useful with connect_cached() XXX not
enabled/tested/documented
- if (0 and $dbh and my $oc = $dbh->{OnConnect}) { # XXX
- $oc->($dbh, $dsn, $user, $pass, $attr) if ref $oc eq 'CODE';
+ # 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;
@@ -1411,9 +1411,11 @@
};
my $dbh = $cache->{$key};
if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) {
- # XXX warn if BegunWork?
- # XXX warn if $dbh->FETCH('AutoCommit') != $attr->{AutoCommit} ?
- # but that's just one (bad) case of a more general issue.
+ # 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;
+ }
return $dbh;
}
$dbh = $drh->connect(@_);
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue Mar 22 16:20:17 2005
@@ -1089,6 +1089,7 @@
if (DBIc_is(imp_xxh, DBIcf_TaintIn)) sv_catpv(flags,"TaintIn ");
if (DBIc_is(imp_xxh, DBIcf_TaintOut)) sv_catpv(flags,"TaintOut ");
if (DBIc_is(imp_xxh, DBIcf_Profile)) sv_catpv(flags,"Profile ");
+ if (DBIc_is(imp_xxh, DBIcf_Callbacks)) sv_catpv(flags,"Callbacks ");
PerlIO_printf(DBILOGFP,"%s FLAGS 0x%lx: %s\n", pad,
(long)DBIc_FLAGS(imp_xxh), SvPV(flags,lna));
PerlIO_printf(DBILOGFP,"%s PARENT %s\n", pad,
neatsvpv((SV*)DBIc_PARENT_H(imp_xxh),0));
PerlIO_printf(DBILOGFP,"%s KIDS %ld (%ld Active)\n", pad,
@@ -1510,6 +1511,12 @@
DBIc_CACHED_KIDS(imp_dbh) = (HV*)SvREFCNT_inc(SvRV(valuesv));
}
}
+ else if (keylen==9 && strEQ(key, "Callbacks")) {
+ if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) )
+ croak("Can't set Callbacks to '%s'",neatsvpv(valuesv,0));
+ DBIc_set(imp_xxh, DBIcf_Callbacks, on);
+ cacheit = 1;
+ }
else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "AutoCommit")) {
/* driver should have intercepted this and either handled it */
/* or set valuesv to either the 'magic' on or off value. */
@@ -1861,6 +1868,7 @@
|| (*key=='P' && strEQ(key, "ParamValues"))
|| (*key=='P' && strEQ(key, "Profile"))
|| (*key=='C' && strEQ(key, "CursorName"))
+ || (*key=='C' && strEQ(key, "Callbacks"))
|| !isUPPER(*key) /* dbd_*, private_* etc */
))
warn("Can't get %s->{%s}: unrecognised
attribute",neatsvpv(h,0),key);
@@ -2385,6 +2393,38 @@
profile_t1 = dbi_time(); /* just get start time here */
}
+ if ((i = DBIc_DEBUGIV(imp_xxh))) { /* merge handle into global */
+ I32 h_trace_level = (i & DBIc_TRACE_LEVEL_MASK);
+ if ( h_trace_level > trace_level )
+ trace_level = h_trace_level;
+ trace_flags = (trace_flags & ~DBIc_TRACE_LEVEL_MASK)
+ | ( i & ~DBIc_TRACE_LEVEL_MASK)
+ | trace_level;
+ }
+
+ if (DBIc_has(imp_xxh,DBIcf_Callbacks)
+ && (hook_svp = hv_fetch((HV*)SvRV(h), "Callbacks", 9, 0))
+ && HvKEYS((HV*)SvRV(*hook_svp))
+ && (hook_svp = hv_fetch((HV*)SvRV(*hook_svp), meth_name,
strlen(meth_name), 0))
+ && SvROK(*hook_svp)
+ ) {
+ dSP;
+ SV *code = SvRV(*hook_svp);
+ if (trace_level)
+ PerlIO_printf(DBILOGFP, "%c {{ %s callback %s being invoked\n",
+ (dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0));
+ PUSHMARK(SP);
+ XPUSHs(h);
+ /* XXX add more params */
+ PUTBACK;
+ if (call_sv(code, G_ARRAY))
+ die("Callback for %s must not return any values (temporary
restriction in current version)");
+ SPAGAIN;
+ if (trace_level)
+ PerlIO_printf(DBILOGFP, "%c }} %s callback %s returned\n",
+ (dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0));
+ }
+
#ifdef DBI_USE_THREADS
{
PerlInterpreter * h_perl = DBIc_THR_USER(imp_xxh) ;
@@ -2494,15 +2534,6 @@
}
}
- if ((i = DBIc_DEBUGIV(imp_xxh))) { /* merge handle into global */
- I32 h_trace_level = (i & DBIc_TRACE_LEVEL_MASK);
- if ( h_trace_level > trace_level )
- trace_level = h_trace_level;
- trace_flags = (trace_flags & ~DBIc_TRACE_LEVEL_MASK)
- | ( i & ~DBIc_TRACE_LEVEL_MASK)
- | trace_level;
- }
-
/* record this inner handle for use by DBI::var::FETCH */
if (is_DESTROY) {
Modified: dbi/trunk/DBIXS.h
==============================================================================
--- dbi/trunk/DBIXS.h (original)
+++ dbi/trunk/DBIXS.h Tue Mar 22 16:20:17 2005
@@ -264,11 +264,12 @@
#define DBIcf_TaintOut 0x040000 /* taint outgoing data */
#define DBIcf_Executed 0x080000 /* do/execute called since commit/rollb
*/
#define DBIcf_PrintWarn 0x100000 /* warn() on warning (err="0")
*/
+#define DBIcf_Callbacks 0x200000 /* has Callbacks attribute hash
*/
/* NOTE: new flags may require clone() to be updated */
#define DBIcf_INHERITMASK /* what NOT to pass on to children */
\
(U32)( DBIcf_COMSET | DBIcf_IMPSET | DBIcf_ACTIVE | DBIcf_IADESTROY
\
- | DBIcf_AutoCommit | DBIcf_BegunWork | DBIcf_Executed )
+ | DBIcf_AutoCommit | DBIcf_BegunWork | DBIcf_Executed | DBIcf_Callbacks )
/* general purpose bit setting and testing macros */
#define DBIbf_is( bitset,flag) ((bitset) & (flag))
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Tue Mar 22 16:20:17 2005
@@ -61,6 +61,7 @@
t/42prof_data.t
t/50dbm.t
t/60preparse.t
+t/70callbacks.t
t/80proxy.t
t/pod.t
test.pl A very simple test harness using
ExampleP.pm
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Tue Mar 22 16:20:17 2005
@@ -143,6 +143,7 @@
Attribution
BegunWork
CachedKids
+ Callbacks
CursorName
Database
DebugDispatch
Added: dbi/trunk/t/70callbacks.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/70callbacks.t Tue Mar 22 16:20:17 2005
@@ -0,0 +1,75 @@
+#!perl -w
+
+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 => 24;
+}
+
+$| = 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 { $called{ping}++; return; } };
+is keys %{ $dbh->{Callbacks} }, 1;
+is ref $dbh->{Callbacks}->{ping}, 'CODE';
+ok $dbh->ping;
+is $called{ping}, 1;
+ok $dbh->ping;
+is $called{ping}, 2;
+$dbh->{Callbacks} = undef;
+ok $dbh->ping;
+is $called{ping}, 2;
+
+=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
+cumbersom 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 => sub { $called{connect}++; return; },
+ "connect_cached.reused" => sub { $called{cached}++; return; },
+ }
+ }
+);
+
+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";
+
+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";
+
+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";
+
