Author: timbo
Date: Mon Apr 23 08:34:09 2007
New Revision: 9444
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/DBIXS.h
dbi/trunk/Driver.xst
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/01basics.t
dbi/trunk/t/06attrs.t
Log:
Reworked CachedKids. It's now just an ordinary attribute.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Apr 23 08:34:09 2007
@@ -41,21 +41,16 @@
=head2 Changes in DBI 1.55 (svn rev XXX), XXX
-XXX DBIc_CACHED_KIDS needs to be an lvalue for Drivers using Driver.xst
-Perl.xs: In function 'XS_DBD__Perl__db_disconnect':
-Perl.xs:277: warning: target of assignment not really an lvalue; this will be
a hard error in the future
-Perl.xs: In function 'XS_DBD__Perl__db_DESTROY':
-Perl.xs:337: warning: target of assignment not really an lvalue; this will be
a hard error in the future
-
-
- Fixed set_err so HandleSetErr hook is executed reliably, if set.
+ Fixed set_err() so HandleSetErr hook is executed reliably, if set.
Fixed accuracy of profiling when perl configured to use long doubles.
Fixed 42prof_data.t on fast systems with poor timers thanks to Malcolm
Nooning.
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 internal implementation of the CachedKids attribute
+ so it's a normal handle attribute (and initially undef).
+ Changed connect_cached and prepare_cached to avoid a FETCH method call,
+ and thereby reduced cost by ~5% and ~30% respectively.
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.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Mon Apr 23 08:34:09 2007
@@ -369,7 +369,7 @@
%DBI::DBI_methods = ( # Define the DBI interface methods per class:
common => { # Interface methods common to all DBI handle
classes
- 'DESTROY' => $keeperr,
+ 'DESTROY' => { O=>0x004|0x10000 },
'CLEAR' => $keeperr,
'EXISTS' => $keeperr,
'FETCH' => { O=>0x0404 },
@@ -402,7 +402,7 @@
},
db => { # Database Session Class Interface
data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 },
- take_imp_data => { U =>[1,1], },
+ take_imp_data => { U =>[1,1], O=>0x10000 },
clone => { U =>[1,2,'[\%attr]'] },
connected => { U =>[1,0], O => 0x0004 },
begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400 },
@@ -420,7 +420,7 @@
selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [,
@bind_params ] ]'], O=>0x2000 },
selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ]
]'], O=>0x2000 },
ping => { U =>[1,1], O=>0x0404 },
- disconnect => { U =>[1,1], O=>0x0400|0x0800 },
+ disconnect => { U =>[1,1], O=>0x0400|0x0800|0x10000 },
quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430 },
quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ],
O=>0x0430 },
rows => $keeperr,
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Mon Apr 23 08:34:09 2007
@@ -120,6 +120,7 @@
#define IMA_SHOW_ERR_STMT 0x2000 /* dbh meth relates to Statement*/
#define IMA_HIDE_ERR_PARAMVALUES 0x4000 /* ParamValues are not relevant
*/
#define IMA_IS_FACTORY 0x8000 /* new h ie connect and prepare */
+#define IMA_CLEAR_CACHED_KIDS 0x10000 /* clear CachedKids before call */
#define DBIc_STATE_adjust(imp_xxh, state) \
(SvOK(state) /* SQLSTATE is implemented by driver */ \
@@ -1147,16 +1148,6 @@
}
}
- /* 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 */
@@ -1244,12 +1235,6 @@
if (DBIc_LongReadLen(imp_xxh) != DBIc_LongReadLen_init)
PerlIO_printf(DBILOGFP,"%s LongReadLen %ld\n", pad,
(long)DBIc_LongReadLen(imp_xxh));
- if (DBIc_TYPE(imp_xxh) <= DBIt_DB) {
- const imp_dbh_t *imp_dbh = (imp_dbh_t*)imp_xxh;
- 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;
PerlIO_printf(DBILOGFP,"%s NUM_OF_FIELDS %d\n", pad,
DBIc_NUM_FIELDS(imp_sth));
@@ -1258,6 +1243,13 @@
inner = dbih_inner((SV*)DBIc_MY_H(imp_xxh), msg);
if (!inner || !SvROK(inner))
return 1;
+ if (DBIc_TYPE(imp_xxh) <= DBIt_DB) {
+ SV **svp = hv_fetch((HV*)SvRV(inner), "CachedKids", 10, 0);
+ if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) {
+ HV *hv = (HV*)SvRV(*svp);
+ PerlIO_printf(DBILOGFP,"%s CachedKids %d\n", pad, (int)HvKEYS(hv));
+ }
+ }
if (level > 0) {
SV* value;
char *key;
@@ -1317,16 +1309,6 @@
dbih_dumpcom(imp_xxh,"DESTROY (dbih_clearcom)", 0);
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 ((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(hv) );
- hv_clear(hv); /* may recurse */
- }
- }
if (DBIc_ACTIVE(imp_xxh)) { /* bad news, potentially */
/* warn for sth, warn for dbh only if it has active sth or isn't
AutoCommit */
@@ -2251,29 +2233,30 @@
static void
-clear_cached_kids(SV *h, imp_xxh_t *imp_xxh, const char *meth_name, int
trace_level)
+clear_cached_kids(pTHX_ SV *h, imp_xxh_t *imp_xxh, const char *meth_name, int
trace_level)
{
- 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);
+ if (DBIc_TYPE(imp_xxh) <= DBIt_DB) {
+ SV **svp = hv_fetch((HV*)SvRV(h), "CachedKids", 10, 0);
+ if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVHV) {
+ HV *hv = (HV*)SvRV(*svp);
+ if (HvKEYS(hv)) {
+ 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);
+ }
}
- /* This will probably recurse through dispatch to DESTROY the kids */
- /* For drh we should probably explicitly do dbh disconnects */
- hv_clear(hv);
}
}
+
static NV
dbi_time() {
# ifdef HAS_GETTIMEOFDAY
@@ -2710,7 +2693,7 @@
}
#endif
if (imp_xxh && DBIc_TYPE(imp_xxh) <= DBIt_DB)
- clear_cached_kids(mg->mg_obj, imp_xxh, meth_name, trace_level);
+ clear_cached_kids(aTHX_ 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
* incremented and then also SvREFCNT_dec(mg->mg_obj) to force
an immediate
@@ -2859,6 +2842,7 @@
XSRETURN(0);
}
if (ima_flags & IMA_FUNC_REDIRECT) {
+ /* XXX this doesn't redispatch, nor consider the IMA of the
new method */
SV *meth_name_sv = POPs;
PUTBACK;
--items;
@@ -2882,6 +2866,9 @@
/* don't use SvOK_off: dbh's Statement may be ref to sth's */
hv_store((HV*)SvRV(h), "Statement", 9, &sv_undef, 0);
}
+ if (ima_flags & IMA_CLEAR_CACHED_KIDS)
+ clear_cached_kids(aTHX_ h, imp_xxh, meth_name, trace_flags);
+
}
if (ima_flags & IMA_HAS_USAGE) {
@@ -2936,8 +2923,6 @@
sv_setsv(DBIc_ERRSTR(parent_imp), DBIc_ERRSTR(imp_xxh));
sv_setsv(DBIc_STATE(parent_imp), DBIc_STATE(imp_xxh));
}
-
- clear_cached_kids(h, imp_xxh, meth_name, trace_flags);
}
if (DBIc_IADESTROY(imp_xxh)) { /* want's ineffective destroy */
@@ -4324,8 +4309,6 @@
* 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)
- 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);
HV *zombie_stash = gv_stashpv("DBI::zombie", GV_ADDWARN);
Modified: dbi/trunk/DBIXS.h
==============================================================================
--- dbi/trunk/DBIXS.h (original)
+++ dbi/trunk/DBIXS.h Mon Apr 23 08:34:09 2007
@@ -133,13 +133,13 @@
typedef struct { /* -- DRIVER -- */
dbih_com_std_t std;
dbih_com_attr_t attr;
- SV **cached_kids_svp; /* \($h->{CachedKids}) */
+ HV *_old_cached_kids; /* not used, here for binary compat */
} dbih_drc_t;
typedef struct { /* -- DATABASE -- */
dbih_com_std_t std; /* \__ standard structure */
dbih_com_attr_t attr; /* / plus... (nothing else right now) */
- SV **cached_kids_svp; /* \($h->{CachedKids}) */
+ HV *_old_cached_kids; /* not used, here for binary compat */
} dbih_dbc_t;
typedef struct { /* -- STATEMENT -- */
@@ -232,8 +232,7 @@
/* handle sub-type specific fields
*/
/* 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)
))
+#define DBIc_CACHED_KIDS(imp) Nullhv /* no longer used, here for src
compat */
/* sth */
#define DBIc_NUM_FIELDS(imp) _imp2com(imp, num_fields)
#define DBIc_NUM_PARAMS(imp) _imp2com(imp, num_params)
Modified: dbi/trunk/Driver.xst
==============================================================================
--- dbi/trunk/Driver.xst (original)
+++ dbi/trunk/Driver.xst Mon Apr 23 08:34:09 2007
@@ -271,11 +271,6 @@
if ( !DBIc_ACTIVE(imp_dbh) ) {
XSRETURN_YES;
}
- /* pre-disconnect checks and tidy-ups */
- if (DBIc_CACHED_KIDS(imp_dbh)) {
- SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh)); /* cast them to the winds
*/
- DBIc_CACHED_KIDS(imp_dbh) = Nullhv;
- }
/* Check for disconnect() being called whilst refs to cursors */
/* still exists. This possibly needs some more thought. */
if (DBIc_ACTIVE_KIDS(imp_dbh) && DBIc_WARN(imp_dbh) && !dirty) {
@@ -331,11 +326,6 @@
SvPV(dbh,lna));
}
else {
- /* pre-disconnect checks and tidy-ups */
- if (DBIc_CACHED_KIDS(imp_dbh)) {
- SvREFCNT_dec(DBIc_CACHED_KIDS(imp_dbh)); /* cast them to the winds
*/
- DBIc_CACHED_KIDS(imp_dbh) = Nullhv;
- }
if (DBIc_IADESTROY(imp_dbh)) { /* want's ineffective destroy
*/
DBIc_ACTIVE_off(imp_dbh);
if (DBIc_DBISTATE(imp_dbh)->debug)
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Mon Apr 23 08:34:09 2007
@@ -128,6 +128,7 @@
use constant IMA_SHOW_ERR_STMT => 0x2000; #/* dbh meth relates to Statement*/
use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not
relevant */
use constant IMA_IS_FACTORY => 0x8000; #/* new h ie connect & prepare */
+use constant IMA_CLEAR_CACHED_KIDS => 0x10000; #/* clear CachedKids before
call */
my %is_flag_attribute = map {$_ =>1 } qw(
Active
@@ -248,6 +249,10 @@
$parent_dbh->{Executed} = 1 if $parent_dbh;
} if IMA_EXECUTE & $bitmask;
+ push @pre_call_frag, q{
+ %{ $h->{CachedKids} } = () if $h->{CachedKids};
+ } if IMA_CLEAR_CACHED_KIDS & $bitmask;
+
if (IMA_KEEP_ERR & $bitmask) {
push @pre_call_frag, q{
my $keep_error = 1;
@@ -484,7 +489,6 @@
}
elsif (ref($parent) =~ /::dr$/){
$h_inner->{Driver} = $parent;
- $h_inner->{CachedKids} ||= {};
}
$h_inner->{_parent} = $parent;
@@ -509,7 +513,6 @@
$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 23 08:34:09 2007
@@ -2,7 +2,7 @@
use strict;
-use Test::More tests => 131;
+use Test::More tests => 130;
use File::Spec;
$|=1;
@@ -176,8 +176,7 @@
cmp_ok(($switch->{private_test1} = 1), '==', 1, '... this should work and
return 1');
cmp_ok($switch->{private_test1}, '==', 1, '... this should equal 1');
-is(ref($switch->{CachedKids}), 'HASH', '... CachedKids should be a HASH
reference');
-ok(!keys %{ $switch->{CachedKids} }, '... CachedKids should be empty');
+is($switch->{CachedKids}, undef, '... CachedKids should be undef initially');
my $cache = {};
$switch->{CachedKids} = $cache;
is($switch->{CachedKids}, $cache, '... CachedKids should be our ref');
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Mon Apr 23 08:34:09 2007
@@ -61,7 +61,7 @@
cmp_ok($dbh->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for
dbh');;
}
-is(ref $dbh->{CachedKids},'HASH', '... checking CachedKids attribute for dbh');
+is($dbh->{CachedKids}, undef, '... 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');
}
-is(ref $drh->{CachedKids},'HASH','... checking CachedKids attribute for drh');
+is($drh->{CachedKids}, undef, '... checking CachedKids attribute for drh');
ok(!defined $drh->{HandleError}, '... checking HandleError attribute for drh');
ok(!defined $drh->{Profile}, '... checking Profile attribute for drh');
