Index: DBI.xs =================================================================== --- DBI.xs (revision 870) +++ DBI.xs (working copy) @@ -1101,6 +1101,8 @@ imp_dbh_t *imp_dbh = (imp_dbh_t*)imp_xxh; if (DBIc_CACHED_KIDS(imp_dbh)) PerlIO_printf(DBILOGFP,"%s CachedKids %d\n", pad, (int)HvKEYS(DBIc_CACHED_KIDS(imp_dbh))); + if (DBIc_CALLBACKS(imp_dbh)) + PerlIO_printf(DBILOGFP,"%s Callbacks %d\n", pad, (int)HvKEYS(DBIc_CALLBACKS(imp_dbh))); } if (DBIc_TYPE(imp_xxh) == DBIt_ST) { imp_sth_t *imp_sth = (imp_sth_t*)imp_xxh; @@ -1510,6 +1512,30 @@ DBIc_CACHED_KIDS(imp_dbh) = (HV*)SvREFCNT_inc(SvRV(valuesv)); } } + else if (htype<=DBIt_DB && keylen==9 && strEQ(key, "Callbacks")) { + if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) ) { + croak("Can't set Callbacks to '%s'",neatsvpv(valuesv,0)); + } + char *key; + I32 klen; + SV *val; + HV *hv = (HV*)GvHV(valuesv); + (void)hv_iterinit(hv); + while ((val = hv_iternextsv(hv, (char **) &key, &klen))) { + if ( on && (!SvROK(val) || (SvTYPE(SvRV(val)) != SVt_PVCV)) ) { + croak("Can't set '%s' callback to '%s'", key, neatsvpv(val,0)); + } + + } + D_imp_dbh(h); /* XXX also for drh */ + if (DBIc_CALLBACKS(imp_dbh)) { + SvREFCNT_dec(DBIc_CALLBACKS(imp_dbh)); + DBIc_CALLBACKS(imp_dbh) = Nullhv; + } + if (SvROK(valuesv)) { + DBIc_CALLBACKS(imp_dbh) = (HV*)SvREFCNT_inc(SvRV(valuesv)); + } + } 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. */ @@ -1728,6 +1754,11 @@ else if (keylen==10 && strEQ(key, "AutoCommit")) { valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_AutoCommit)); } + else if (keylen==9 && strEQ(key, "Callbacks")) { + D_imp_dbh(h); + HV *hv = DBIc_CALLBACKS(imp_dbh); + valuesv = (hv) ? newRV((SV*)hv) : &sv_undef; + } } if (valuesv == Nullsv) { @@ -1757,6 +1788,9 @@ else if (strEQ(key, "CompatMode")) { valuesv = boolSV(DBIc_COMPAT(imp_xxh)); } + else if (strEQ(key, "Callbacks")) { + valuesv = &sv_undef; + } break; case 'E': Index: DBIXS.h =================================================================== --- DBIXS.h (revision 870) +++ DBIXS.h (working copy) @@ -134,12 +134,14 @@ dbih_com_std_t std; dbih_com_attr_t attr; HV *cached_kids; /* $drh->connect_cached(...) */ + HV *callbacks; /* $drh->{Callbacks}->{cb}->(...) */ } dbih_drc_t; typedef struct { /* -- DATABASE -- */ dbih_com_std_t std; /* \__ standard structure */ dbih_com_attr_t attr; /* / plus... (nothing else right now) */ HV *cached_kids; /* $dbh->prepare_cached(...) */ + HV *callbacks; /* $drh->{Callbacks}->{cb}->(...) */ } dbih_dbc_t; typedef struct { /* -- STATEMENT -- */ @@ -233,6 +235,7 @@ /* handle sub-type specific fields */ /* dbh */ #define DBIc_CACHED_KIDS(imp) _imp2com(imp, cached_kids) +#define DBIc_CALLBACKS(imp) _imp2com(imp, callbacks) /* sth */ #define DBIc_NUM_FIELDS(imp) _imp2com(imp, num_fields) #define DBIc_NUM_PARAMS(imp) _imp2com(imp, num_params) @@ -264,6 +267,7 @@ #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 0x110000 /* callback to code references */ /* NOTE: new flags may require clone() to be updated */ #define DBIcf_INHERITMASK /* what NOT to pass on to children */ \ Index: lib/DBI/PurePerl.pm =================================================================== --- lib/DBI/PurePerl.pm (revision 870) +++ lib/DBI/PurePerl.pm (working copy) @@ -143,6 +143,7 @@ Attribution BegunWork CachedKids + Callbacks CursorName Database DebugDispatch Index: DBI.pm =================================================================== --- DBI.pm (revision 870) +++ DBI.pm (working copy) @@ -650,10 +650,9 @@ # 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 ($dbh and my $cb = $dbh->{Callbacks}{connect}) { + $cb->($dbh, $dsn, $user, $pass, $attr); } DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug; @@ -1409,9 +1408,10 @@ }; 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}{"connect_cached.reused"}) { + $cb->($dbh, $dsn, $user, $auth, $attr); + } return $dbh; } $dbh = $drh->connect(@_); --- /dev/null Mon Feb 21 16:09:28 2005 +++ t/11callbacks.t Mon Feb 21 16:09:20 2005 @@ -0,0 +1,35 @@ +#!perl -w + +use strict; + +use Test::More tests => 10; +use File::Spec; + +$|=1; + +BEGIN { use_ok 'DBI' or die; } + +my $driver = "ExampleP"; + +my ($connect, $cached); +my @args = ( + "dbi:$driver:", '', '', { + Callbacks => { + connect => sub { $connect++ }, + "connect_cached.reused" => sub { $cached++ }, + } + } +); + +ok my $dbh = DBI->connect(@args), "Create handle with callbacks"; +is $connect, 1, "Connect callback called once."; +is $cached, undef, "Cached not yet called"; + +ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks"; +is $connect, 2, "Connect callback called by connect_cached."; +is $cached, undef, "Cached still not yet called"; + +ok $dbh = DBI->connect_cached(@args), "Create handle with callbacks"; +is $connect, 3, "Connect callback called by second connect_cached."; +is $cached, 1, "Cached called"; +