Author: timbo
Date: Mon Nov 21 16:47:06 2005
New Revision: 2254
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/72childhandles.t
Log:
Move ChildHandles support into C code (and PurePerl).
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Nov 21 16:47:06 2005
@@ -17,7 +17,8 @@ DBI::Changes - List of significant chang
Fixed prerequisites to include Storable thanks to Michael Schwern.
XXX TODO: take_imp_data
-XXX TODO: move ChildHandles code into .xs and PurePerl
+XXX TODO: add skip to t/72childhandles if weaken isn't available
+XXX TODO: fix bus error from t/03handles.t
Change to require perl 5.6.1 (as advertised in 2003) not 5.6.0.
Changed internals to be more strictly coded thanks to Andy Lester.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Mon Nov 21 16:47:06 2005
@@ -277,7 +277,7 @@ my $HAS_WEAKEN = eval {
require Scalar::Util;
# this will croak() if this Scalar::Util doesn't have a working weaken().
Scalar::Util::weaken(my $test = \"foo");
- 0;
+ 1;
};
%DBI::installed_drh = (); # maps driver names to installed driver handles
@@ -458,7 +458,7 @@ my $keeperr = { O=>0x0004 };
);
while ( my ($class, $meths) = each %DBI::DBI_methods ) {
- my $ima_trace = 0+$ENV{DBI_IMA_TRACE}||0;
+ my $ima_trace = 0+($ENV{DBI_IMA_TRACE}||0);
while ( my ($method, $info) = each %$meths ) {
my $fullmeth = "DBI::${class}::$method";
if ($DBI::dbi_debug >= 15) { # quick hack to list DBI methods
@@ -1181,20 +1181,6 @@ sub _new_handle {
# Now add magic so DBI method dispatch works
DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
- # add to the parent's ChildHandles
- if ($HAS_WEAKEN && $parent) {
- my $handles = $parent->{ChildHandles} ||= [];
-
- # purge destroyed handles occasionally
- if (@$handles % 120 == 0 and @$handles) {
- @$handles = grep { defined } @$handles;
- Scalar::Util::weaken($_) for @$handles; # re-weaken after grep
- }
-
- push @$handles, $h;
- Scalar::Util::weaken($handles->[-1]);
- }
-
return $h unless wantarray;
($h, $i);
}
@@ -3335,9 +3321,9 @@ statement handles.
The ChildHandles attribute contains a reference to an array of all the
handles created by this handle which are still accessible. The
contents of the array are weak-refs and will become undef when the
-handle goes out of scope. C<ChildHandles> is only available if you
-have the L<Scalar::Util|Scalar::Util> module installed and
-C<Scalar::Util::weaken()> is working.
+handle goes out of scope. C<ChildHandles> returns undef if your perl version
+does not support weak references (check the L<Scalar::Util|Scalar::Util>
+module). The referenced array returned should be treated as read-only.
For example, to enumerate all driver handles, database handles and
statement handles:
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Mon Nov 21 16:47:06 2005
@@ -1033,6 +1033,26 @@ dbih_setup_handle(SV *orv, char *imp_cla
dbih_setup_attrib(h,imp,"Profile",parent,0,1);
}
DBIc_LongReadLen(imp) = DBIc_LongReadLen(parent_imp);
+#ifdef sv_rvweaken
+ if (1) {
+ AV *av;
+ /* add weakref to new (outer) handle into parents ChildHandles
array */
+ tmp_svp = hv_fetch((HV*)SvRV(parent), "ChildHandles", 12, 1);
+ if (!SvROK(*tmp_svp))
+ sv_setsv(*tmp_svp, (SV*)newRV_noinc((SV*)newAV()));
+ av = (AV*)SvRV(*tmp_svp);
+ av_push(av, (SV*)sv_rvweaken(newRV((SV*)SvRV(orv))));
+ if (av_len(av) % 120 == 0) {
+ /* time to do some housekeeping to remove dead handles */
+ I32 i = av_len(av); /* 0 = 1 element */
+ while (i-- >= 0) {
+ SV *sv = av_shift(av);
+ if (SvOK(sv))
+ av_push(av, sv);
+ }
+ }
+ }
+#endif
}
else {
DBIc_LongReadLen(imp) = DBIc_LongReadLen_init;
@@ -1452,19 +1472,22 @@ dbih_set_attr_k(SV *h, SV *keysv, int db
}
else if (strEQ(key, "HandleError")) {
if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVCV)) ) {
- croak("Can't set HandleError to '%s'",neatsvpv(valuesv,0));
+ croak("Can't set %s to '%s'", "HandleError", neatsvpv(valuesv,0));
}
DBIc_set(imp_xxh,DBIcf_HandleError, on);
cacheit = 1; /* child copy setup by dbih_setup_handle() */
}
else if (strEQ(key, "HandleSetErr")) {
if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVCV)) ) {
- croak("Can't set HandleSetErr to '%s'",neatsvpv(valuesv,0));
+ croak("Can't set %s to '%s'","HandleSetErr",neatsvpv(valuesv,0));
}
DBIc_set(imp_xxh,DBIcf_HandleSetErr, on);
cacheit = 1; /* child copy setup by dbih_setup_handle() */
}
else if (strEQ(key, "ChildHandles")) {
+ if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVAV)) ) {
+ croak("Can't set %s to '%s'", "ChildHandles", neatsvpv(valuesv,0));
+ }
cacheit = 1; /* just save it in the hash */
}
else if (strEQ(key, "Profile")) {
@@ -1782,21 +1805,27 @@ dbih_get_attr_k(SV *h, SV *keysv, int db
break;
case 'C':
- if (strEQ(key, "ChopBlanks")) {
+ if (strEQ(key, "ChildHandles")) {
+ svp = hv_fetch((HV*)SvRV(h), key, keylen, FALSE);
+ /* if something has been stored then return it.
+ * otherwise return a dummy empty array if weakrefs are
+ * available, else an undef to indicate that they're not */
+ if (svp) {
+ valuesv = newSVsv(*svp);
+ } else {
+#ifdef sv_rvweaken
+ valuesv = newRV_noinc((SV*)newAV());
+#else
+ valuesv = &sv_undef;
+#endif
+ }
+ }
+ else if (strEQ(key, "ChopBlanks")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_ChopBlanks));
}
else if (strEQ(key, "CachedKids")) {
valuesv = &sv_undef;
}
- else if (strEQ(key, "ChildHandles")) {
- /* get the value from the hash, otherwise return a [] */
- svp = hv_fetch((HV*)SvRV(h), key, keylen, FALSE);
- if (svp) {
- valuesv = newSVsv(*svp);
- } else {
- valuesv = newRV_noinc((SV*)newAV());
- }
- }
else if (strEQ(key, "CompatMode")) {
valuesv = boolSV(DBIc_COMPAT(imp_xxh));
}
@@ -2404,7 +2433,7 @@ XS(XS_DBI_dispatch) /* prototype
/* However, we must at least modify DBIc_MY_H() as that is */
/* pointing (without a refcnt inc) to the scalar that is */
/* being destroyed, so it'll contain random values later. */
- DBIc_MY_H(imp_xxh) = SvRV(mg->mg_obj); /* inner (untied) HV */
+ DBIc_MY_H(imp_xxh) = (void*)SvRV(mg->mg_obj); /* inner (untied) HV
*/
XSRETURN(0);
}
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Mon Nov 21 16:47:06 2005
@@ -38,6 +38,13 @@ $DBI::tfh = Symbol::gensym();
open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!";
select( (select($DBI::tfh), $| = 1)[0] ); # autoflush
+# check for weaken support, used by ChildHandles
+my $HAS_WEAKEN = eval {
+ require Scalar::Util;
+ # this will croak() if this Scalar::Util doesn't have a working weaken().
+ Scalar::Util::weaken(my $test = \"foo");
+ 1;
+};
%DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err);
@@ -443,6 +450,18 @@ sub _setup_handle {
$h_inner->{Driver} = $parent;
}
$h_inner->{_parent} = $parent;
+
+ # add to the parent's ChildHandles
+ if ($HAS_WEAKEN) {
+ my $handles = $parent->{ChildHandles} ||= [];
+ push @$handles, $h;
+ Scalar::Util::weaken($handles->[-1]);
+ # purge destroyed handles occasionally
+ if (@$handles % 120 == 0) {
+ @$handles = grep { defined } @$handles;
+ Scalar::Util::weaken($_) for @$handles; # re-weaken after grep
+ }
+ }
}
else { # setting up a driver handle
$h_inner->{Warn} = 1;
@@ -452,6 +471,7 @@ sub _setup_handle {
$h_inner->{CompatMode} = (1==0);
$h_inner->{FetchHashKeyName} ||= 'NAME';
$h_inner->{LongReadLen} ||= 80;
+ $h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN;
}
$h_inner->{"_call_depth"} = 0;
$h_inner->{ErrCount} = 0;
Modified: dbi/trunk/t/72childhandles.t
==============================================================================
--- dbi/trunk/t/72childhandles.t (original)
+++ dbi/trunk/t/72childhandles.t Mon Nov 21 16:47:06 2005
@@ -8,29 +8,45 @@ use strict;
use DBI;
-use Test;
-BEGIN { plan tests => 22; }
+use Test::More;
+
+my $HAS_WEAKEN = eval {
+ require Scalar::Util;
+ # this will croak() if this Scalar::Util doesn't have a working weaken().
+ Scalar::Util::weaken(my $test = \"foo");
+ 1;
+};
+if (!$HAS_WEAKEN) {
+ print "1..0 # Skipped: Scalar::Util::weaken not available\n";
+ exit 0;
+}
+
+plan tests => 15;
+
{
# make 10 connections
my @dbh;
for (1 .. 10) {
my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
- push(@dbh, $dbh);
+ push @dbh, $dbh;
}
# get the driver handle
my %drivers = DBI->installed_drivers();
my $driver = $drivers{ExampleP};
- ok($driver);
+ ok $driver;
- # get the kids, should be the 10 connections
+ # get the kids, should be the same list of connections
my $db_handles = $driver->{ChildHandles};
- ok(scalar @$db_handles, 10);
+ is ref $db_handles, 'ARRAY';
+ is scalar @$db_handles, scalar @dbh;
# make sure all the handles are there
+ my $found = 0;
foreach my $h (@dbh) {
- ok(grep { $h == $_ } @$db_handles);
+ ++$found if grep { $h == $_ } @$db_handles;
}
+ is $found, scalar @dbh;
}
# now all the out-of-scope DB handles should be gone
@@ -40,15 +56,15 @@ BEGIN { plan tests => 22; }
my $handles = $driver->{ChildHandles};
my @db_handles = grep { defined } @$handles;
- ok(scalar @db_handles, 0);
+ is scalar @db_handles, 0, "All handles should be undef now";
}
my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
-# ChildHandles should start with an empty array-ref
my $empty = $dbh->{ChildHandles};
-ok(scalar @$empty, 0);
+is ref $empty, 'ARRAY', "ChildHandles should be an array-ref if wekref is
available";
+is scalar @$empty, 0, "ChildHandles should start with an empty array-ref";
# test child handles for statement handles
{
@@ -58,7 +74,7 @@ ok(scalar @$empty, 0);
push(@sth, $sth);
}
my $handles = $dbh->{ChildHandles};
- ok(scalar @$handles, 200);
+ is scalar @$handles, scalar @sth;
# test a recursive walk like the one in the docs
my @lines;
@@ -71,17 +87,17 @@ ok(scalar @$empty, 0);
for (grep { defined } @{$h->{ChildHandles}});
}
show_child_handles($_) for (values %{{DBI->installed_drivers()}});
+ print @lines[0..4];
- ok(scalar @lines, 202);
- ok($lines[0] =~ /^drh/);
- ok($lines[1] =~ /^dbh/);
- ok($lines[2] =~ /^sth/);
+ is scalar @lines, 202;
+ like $lines[0], qr/^drh/;
+ like $lines[1], qr/^dbh/;
+ like $lines[2], qr/^sth/;
}
-# they should be gone now
my $handles = $dbh->{ChildHandles};
my @live = grep { defined $_ } @$handles;
-ok(scalar @live, 0);
+is scalar @live, 0, "handles should be gone now";
# test that the childhandle array does not grow uncontrollably
{
@@ -89,7 +105,7 @@ ok(scalar @live, 0);
my $sth = $dbh->prepare('SELECT name FROM t');
}
my $handles = $dbh->{ChildHandles};
- ok(scalar @$handles < 1000);
+ cmp_ok scalar @$handles, '<', 1000;
my @live = grep { defined } @$handles;
- ok(scalar @live, 0);
+ is scalar @live, 0;
}
