Author: timbo
Date: Mon Apr 16 15:28:24 2007
New Revision: 9419
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/DBIXS.h
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/01basics.t
dbi/trunk/t/06attrs.t
Log:
Convert CachedKids into an (almost) normal attribute
to avoid need for FETCH in connect_cached and prepare_cached.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Apr 16 15:28:24 2007
@@ -24,17 +24,15 @@
Pedantic policy should force a fresh connect each time - add new policy item
Add attr-passthru to prepare()? ie for gofer cache control
Terminology for client and server ends
-Document user/passwd issues at the various levels of the stack
+Document user/passwd issues at the various levels of the gofer stack
Policy's from pod
Policy for dbh attr FETCH (ie example_driver_path)
or piggyback on skip_connect_check
could also remember which attr have been returned to us
so not bother FETCHing them (unless pedantic)
Refactor http transport like the others re timeout
-Call method on transport timeout so transport can cleanup/reset it it wants
+Call method on transport failure so transport can cleanup/reset it it wants
-Implement tie in C.
-Make CachedKids a plain attrib to avoid FETCH in connect_cached/prepare_cached
prepare(...,{ Err=>\my $isolated_err, ...})
Add trace modules that just records the last N trace messages into an array
and prepends them to any error message.
@@ -46,21 +44,23 @@
Fixed 42prof_data.t on fast systems with poor timers thanks to Malcolm
Nooning.
Fixed gofer pipeone & stream transports to avoid risk of hanging.
- Changed DBD::Gofer to work around a DBD::Sybase bind_param bug
- (which is now fixed in DBD::Sybase 1.07)
+ Changed some handle creation code from perl to C code,
+ to reduce handle creation cost by ~20%.
+ Changed connect_cached and prepare_cached to avoid a method call which
+ reduced cost by ~5% for connect_cached and ~30% for prepare_cached.
Changed _set_fbav to not croak when given a wrongly sized array,
it now warns and adjusts the row buffer to match.
Changed DBD::NullP to be slightly more useful for testing.
Changed File::Spec prerequisite to not require a minimum version.
Changed tests to work with other DBMs thanks to ZMAN.
- Changed some handle creation code from perl to C code,
- so handle creation cost reduced by ~20%.
- Many assorted Gofer related bug fixes, enhancements and docs.
+ Changed DBD::Gofer to work around a DBD::Sybase bind_param bug
+ (which is now fixed in DBD::Sybase 1.07)
+ Many other assorted Gofer related bug fixes, enhancements and docs.
- Added goferperf.pl utility (doesn't get installed).
- Added dbilogstrip utility (gets installed)
Added support for DBI Profile Path to contain refs to scalars
which will be de-ref'd for each profile sample.
+ Added goferperf.pl utility (doesn't get installed).
+ Added dbilogstrip utility (gets installed)
=head2 Changes in DBI 1.54 (svn rev 9157), 23rd February 2007
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Mon Apr 16 15:28:24 2007
@@ -1410,14 +1410,10 @@
sub connect_cached {
- my $drh = shift;
- my ($dsn, $user, $auth, $attr)= @_;
+ my $drh = shift;
+ my ($dsn, $user, $auth, $attr) = @_;
- # Needs support at dbh level to clear cache before complaining about
- # active children. The XS template code does this. Drivers not using
- # the template must handle clearing the cache themselves.
- my $cache = $drh->FETCH('CachedKids');
- $drh->STORE('CachedKids', $cache = {}) unless $cache;
+ my $cache = $drh->{CachedKids} ||= {};
my @attr_keys = $attr ? sort keys %$attr : ();
my $key = do { local $^W; # silence undef warnings
@@ -1627,8 +1623,7 @@
# Needs support at dbh level to clear cache before complaining about
# active children. The XS template code does this. Drivers not using
# the template must handle clearing the cache themselves.
- my $cache = $dbh->FETCH('CachedKids');
- $dbh->STORE('CachedKids', $cache = {}) unless $cache;
+ my $cache = $dbh->{CachedKids} ||= {};
my @attr_keys = ($attr) ? sort keys %$attr : ();
my $key = ($attr) ? join("~~", $statement, @attr_keys, @[EMAIL
PROTECTED]) : $statement;
my $sth = $cache->{$key};
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Mon Apr 16 15:28:24 2007
@@ -1147,6 +1147,16 @@
}
}
+ /* setup CachedKids */
+ if (DBIc_TYPE(imp) < DBIt_ST) {
+ SV **tmp_svp = hv_fetch((HV*)SvRV(h), "CachedKids", 10, 1);
+ imp_dbh_t *imp_dbh = (imp_dbh_t*)imp; /* also drh */
+ if (!SvROK(*tmp_svp) || SvTYPE(SvRV(*tmp_svp)) != SVt_PVHV) {
+ sv_setsv(*tmp_svp, newRV_noinc((SV*)newHV()));
+ }
+ DBIc_CACHED_KIDS_SVP(imp_dbh) = tmp_svp;
+ }
+
/* Use DBI magic on inner handle to carry handle attributes */
sv_magic(SvRV(h), dbih_imp_sv, DBI_MAGIC, Nullch, 0);
SvREFCNT_dec(dbih_imp_sv); /* since sv_magic() incremented it */
@@ -1236,8 +1246,9 @@
if (DBIc_TYPE(imp_xxh) <= DBIt_DB) {
const 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)));
+ HV *hv = DBIc_CACHED_KIDS(imp_dbh);
+ if (hv && HvKEYS(hv))
+ PerlIO_printf(DBILOGFP,"%s CachedKids %d\n", pad, (int)HvKEYS(hv));
}
if (DBIc_TYPE(imp_xxh) == DBIt_ST) {
const imp_sth_t *imp_sth = (imp_sth_t*)imp_xxh;
@@ -1307,13 +1318,13 @@
if (!dirty) {
if (DBIc_TYPE(imp_xxh) <= DBIt_DB) {
+ HV *hv;
imp_dbh_t *imp_dbh = (imp_dbh_t*)imp_xxh; /* works for DRH also */
- if (DBIc_CACHED_KIDS(imp_dbh)) {
+ if ((hv=DBIc_CACHED_KIDS(imp_dbh)) && HvKEYS(hv)>0) {
warn("DBI %s handle 0x%lx cleared whilst still holding %d
cached kids",
dbih_htype_name(DBIc_TYPE(imp_xxh)),
- (unsigned long)DBIc_MY_H(imp_xxh),
(int)HvKEYS(DBIc_CACHED_KIDS(imp_dbh)) );
- SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh)); /* may recurse */
- DBIc_CACHED_KIDS(imp_dbh) = Nullhv;
+ (unsigned long)DBIc_MY_H(imp_xxh), (int)HvKEYS(hv) );
+ hv_clear(hv); /* may recurse */
}
}
@@ -1708,15 +1719,11 @@
else if (strEQ(key, "TaintOut")) {
DBIc_set(imp_xxh,DBIcf_TaintOut, on);
}
- else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "CachedKids")) {
- D_imp_dbh(h); /* XXX also for drh */
- if (DBIc_CACHED_KIDS(imp_dbh)) {
- SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh));
- DBIc_CACHED_KIDS(imp_dbh) = Nullhv;
- }
- if (SvROK(valuesv)) {
- DBIc_CACHED_KIDS(imp_dbh) = (HV*)SvREFCNT_inc(SvRV(valuesv));
- }
+ else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "CachedKids")
+ /* only allow hash refs */
+ && SvROK(valuesv) && SvTYPE(SvRV(valuesv))==SVt_PVHV
+ ) {
+ cacheit = 1;
}
else if (keylen==9 && strEQ(key, "Callbacks")) {
if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) )
@@ -1940,12 +1947,7 @@
}
if (valuesv == Nullsv && htype <= DBIt_DB) {
- if (keylen==10 && strEQ(key, "CachedKids")) {
- D_imp_dbh(h);
- HV *hv = DBIc_CACHED_KIDS(imp_dbh);
- valuesv = (hv) ? newRV((SV*)hv) : &sv_undef;
- }
- else if (keylen==10 && strEQ(key, "AutoCommit")) {
+ if (keylen==10 && strEQ(key, "AutoCommit")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_AutoCommit));
}
}
@@ -2251,20 +2253,24 @@
static void
clear_cached_kids(SV *h, imp_xxh_t *imp_xxh, const char *meth_name, int
trace_level)
{
- dTHX;
- dPERINTERP;
- if (DBIc_TYPE(imp_xxh) <= DBIt_DB &&
DBIc_CACHED_KIDS((imp_drh_t*)imp_xxh)) {
- if (DBIc_TRACE_LEVEL(imp_xxh) > trace_level)
- trace_level = DBIc_TRACE_LEVEL(imp_xxh);
- if (trace_level >= 2) {
- PerlIO_printf(DBILOGFP," >> %s %s clearing %d CachedKids\n",
- meth_name, neatsvpv(h,0),
(int)HvKEYS(DBIc_CACHED_KIDS((imp_drh_t*)imp_xxh)));
- PerlIO_flush(DBILOGFP);
- }
- /* This will probably recurse through dispatch to DESTROY the kids */
- /* For drh we should probably explicitly do dbh disconnects */
- SvREFCNT_dec(DBIc_CACHED_KIDS((imp_drh_t*)imp_xxh));
- DBIc_CACHED_KIDS((imp_drh_t*)imp_xxh) = Nullhv;
+ HV *hv;
+
+ if (DBIc_TYPE(imp_xxh) > DBIt_DB)
+ return;
+ hv = DBIc_CACHED_KIDS((imp_drh_t*)imp_xxh);
+ if (hv && HvKEYS(hv)) {
+ dTHX;
+ dPERINTERP;
+ if (DBIc_TRACE_LEVEL(imp_xxh) > trace_level)
+ trace_level = DBIc_TRACE_LEVEL(imp_xxh);
+ if (trace_level >= 2) {
+ PerlIO_printf(DBILOGFP," >> %s %s clearing %d CachedKids\n",
+ meth_name, neatsvpv(h,0), (int)HvKEYS(hv));
+ PerlIO_flush(DBILOGFP);
+ }
+ /* This will probably recurse through dispatch to DESTROY the kids */
+ /* For drh we should probably explicitly do dbh disconnects */
+ hv_clear(hv);
}
}
@@ -2703,7 +2709,7 @@
goto is_DESTROY_wrong_thread;
}
#endif
- if (imp_xxh && DBIc_TYPE(imp_xxh) <= DBIt_DB &&
DBIc_CACHED_KIDS((imp_drh_t*)imp_xxh))
+ if (imp_xxh && DBIc_TYPE(imp_xxh) <= DBIt_DB)
clear_cached_kids(mg->mg_obj, imp_xxh, meth_name, trace_level);
if (trace_level >= 3) {
/* XXX might be better to move this down to after call_depth
has been
@@ -2931,8 +2937,7 @@
sv_setsv(DBIc_STATE(parent_imp), DBIc_STATE(imp_xxh));
}
- if (DBIc_CACHED_KIDS((imp_drh_t*)imp_xxh))
- clear_cached_kids(h, imp_xxh, meth_name, trace_flags);
+ clear_cached_kids(h, imp_xxh, meth_name, trace_flags);
}
if (DBIc_IADESTROY(imp_xxh)) { /* want's ineffective destroy */
@@ -3883,19 +3888,18 @@
SV * imp_datasv
SV * imp_class
PPCODE:
- dTHX;
dPERINTERP;
HV *outer;
SV *outer_ref;
- GV *class_stash = gv_stashsv(class, GV_ADDWARN);
- (void)cv;
+ HV *class_stash = gv_stashsv(class, GV_ADDWARN);
if (DBIS_TRACE_LEVEL >= 3) {
PerlIO_printf(DBILOGFP, " New %s (for %s, parent=%s, id=%s)\n",
neatsvpv(class,0), SvPV_nolen(imp_class), neatsvpv(parent,0),
neatsvpv(imp_datasv,0));
+ (void)cv; /* avoid unused warning */
}
- hv_store(SvRV(attr_ref), "ImplementorClass", 16, SvREFCNT_inc(imp_class),
0);
+ hv_store((HV*)SvRV(attr_ref), "ImplementorClass", 16,
SvREFCNT_inc(imp_class), 0);
/* make attr into inner handle by blessing it into class */
sv_bless(attr_ref, class_stash);
@@ -3906,16 +3910,7 @@
sv_bless(outer_ref, class_stash);
/* tie outer handle to inner handle */
sv_magic((SV*)outer, attr_ref, PERL_MAGIC_tied, Nullch, 0);
- /*SvREFCNT_dec(attr_ref); /* because sv_magic() incremented it */
- /*
- my (%outer, $i, $h);
- $i = tie %outer, $class, $attr; # ref to inner hash (for driver)
- $h = bless \%outer, $class; # ref to outer hash (for
application)
- DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
- return $h unless wantarray;
- return ($h, $i);
- */
dbih_setup_handle(outer_ref, SvPV_nolen(imp_class), parent,
SvOK(imp_datasv) ? imp_datasv : Nullsv);
/* return outer handle, plus inner handle if not in scalar context */
@@ -4329,7 +4324,7 @@
* destroyed they may need to interact with the 'zombie' parent dbh.
* So we do our best to neautralize them (finish & rebless)
*/
- if (DBIc_TYPE(imp_xxh) <= DBIt_DB && DBIc_CACHED_KIDS((imp_dbh_t*)imp_xxh))
+ if (DBIc_TYPE(imp_xxh) <= DBIt_DB)
clear_cached_kids(h, imp_xxh, "take_imp_data", 0);
if ((tmp_svp = hv_fetch((HV*)SvRV(h), "ChildHandles", 12, FALSE)) &&
SvROK(*tmp_svp)) {
AV *av = (AV*)SvRV(*tmp_svp);
Modified: dbi/trunk/DBIXS.h
==============================================================================
--- dbi/trunk/DBIXS.h (original)
+++ dbi/trunk/DBIXS.h Mon Apr 16 15:28:24 2007
@@ -133,13 +133,13 @@
typedef struct { /* -- DRIVER -- */
dbih_com_std_t std;
dbih_com_attr_t attr;
- HV *cached_kids; /* $drh->connect_cached(...) */
+ SV **cached_kids_svp; /* \($h->{CachedKids}) */
} 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(...) */
+ SV **cached_kids_svp; /* \($h->{CachedKids}) */
} dbih_dbc_t;
typedef struct { /* -- STATEMENT -- */
@@ -231,8 +231,9 @@
#define DBIc_FetchHashKeyName(imp) (_imp2com(imp, attr.FetchHashKeyName))
/* handle sub-type specific fields
*/
-/* dbh */
-#define DBIc_CACHED_KIDS(imp) _imp2com(imp, cached_kids)
+/* dbh & drh */
+#define DBIc_CACHED_KIDS_SVP(imp) _imp2com(imp, cached_kids_svp)
+#define DBIc_CACHED_KIDS(imp) ((HV*)SvRV( *DBIc_CACHED_KIDS_SVP(imp)
))
/* sth */
#define DBIc_NUM_FIELDS(imp) _imp2com(imp, num_fields)
#define DBIc_NUM_PARAMS(imp) _imp2com(imp, num_params)
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Mon Apr 16 15:28:24 2007
@@ -484,6 +484,7 @@
}
elsif (ref($parent) =~ /::dr$/){
$h_inner->{Driver} = $parent;
+ $h_inner->{CachedKids} ||= {};
}
$h_inner->{_parent} = $parent;
@@ -508,6 +509,7 @@
$h_inner->{FetchHashKeyName} ||= 'NAME';
$h_inner->{LongReadLen} ||= 80;
$h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN;
+ $h_inner->{CachedKids} ||= {};
$h_inner->{Type} ||= 'dr';
}
$h_inner->{"_call_depth"} = 0;
Modified: dbi/trunk/t/01basics.t
==============================================================================
--- dbi/trunk/t/01basics.t (original)
+++ dbi/trunk/t/01basics.t Mon Apr 16 15:28:24 2007
@@ -2,7 +2,7 @@
use strict;
-use Test::More tests => 132;
+use Test::More tests => 131;
use File::Spec;
$|=1;
@@ -176,11 +176,11 @@
cmp_ok(($switch->{private_test1} = 1), '==', 1, '... this should work and
return 1');
cmp_ok($switch->{private_test1}, '==', 1, '... this should equal 1');
-ok(!defined $switch->{CachedKids}, '... CachedKids shouldnt be defined');
-ok(($switch->{CachedKids} = { }), '... assigned empty hash to
CachedKids');
is(ref($switch->{CachedKids}), 'HASH', '... CachedKids should be a HASH
reference');
-
-cmp_ok(scalar(keys(%{$switch->{CachedKids}})), '==', 0, '... CachedKids should
be an empty HASH reference');
+ok(!keys %{ $switch->{CachedKids} }, '... CachedKids should be empty');
+my $cache = {};
+$switch->{CachedKids} = $cache;
+is($switch->{CachedKids}, $cache, '... CachedKids should be our ref');
cmp_ok($switch->{Kids}, '==', 0, '... this should be zero');
cmp_ok($switch->{ActiveKids}, '==', 0, '... this should be zero');
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Mon Apr 16 15:28:24 2007
@@ -61,7 +61,7 @@
cmp_ok($dbh->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for
dbh');;
}
-ok(!defined $dbh->{CachedKids}, '... checking CachedKids attribute for dbh');
+is(ref $dbh->{CachedKids},'HASH', '... checking CachedKids attribute for dbh');
ok(!defined $dbh->{HandleError}, '... checking HandleError attribute for
dbh');
ok(!defined $dbh->{Profile}, '... checking Profile attribute for dbh');
ok(!defined $dbh->{Statement}, '... checking Statement attribute for dbh');
@@ -128,7 +128,7 @@
cmp_ok($drh->{ActiveKids}, '==', 1, '... checking ActiveKids attribute for
drh');
}
-ok(!defined $drh->{CachedKids}, '... checking CachedKids attribute for drh');
+is(ref $drh->{CachedKids},'HASH','... checking CachedKids attribute for drh');
ok(!defined $drh->{HandleError}, '... checking HandleError attribute for drh');
ok(!defined $drh->{Profile}, '... checking Profile attribute for drh');
