Here's a revised version of the ChildHandles patch. I think I've
implemented all the requested changes. I also added an implementation
of Type for DBI::PurePerl which was missing.
-sam
diff -Naur DBI-1.48.orig/DBI.pm DBI-1.48/DBI.pm
--- DBI-1.48.orig/DBI.pm 2005-03-14 11:45:38.000000000 -0500
+++ DBI-1.48/DBI.pm 2005-06-27 14:17:17.166716296 -0400
@@ -21,6 +21,7 @@
use DBI;
@driver_names = DBI->available_drivers;
+ %drivers = DBI->installed_drivers;
@data_sources = DBI->data_sources($driver_name, \%attr);
$dbh = DBI->connect($data_source, $username, $auth, \%attr);
@@ -271,7 +272,16 @@
DBI->trace_msg("DBI connect via $DBI::connect_via in
$INC{'Apache/DBI.pm'}\n");
}
+# 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::installed_drh = (); # maps driver names to installed driver handles
+sub installed_drivers { %DBI::installed_drh }
# Setup special DBI dynamic variables. See DBI::var::FETCH for details.
# These are dynamically associated with the last handle used.
@@ -1166,6 +1176,20 @@
# 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);
}
@@ -2700,6 +2724,13 @@
some drivers are hidden by others of the same name in earlier
directories. Passing a true value for C<$quiet> will inhibit the warning.
+=item C<installed_drivers>
+
+ %drivers = DBI->installed_drivers();
+
+Returns a list of driver name and driver handle pairs for all
+installed drivers. The driver name does not include the 'DBD::'
+prefix.
=item C<installed_versions>
@@ -3275,6 +3306,35 @@
driver handle, returns a reference to the cache (hash) of
database handles created by the L</connect_cached> method.
+=item C<Type> (scalar)
+
+The C<Type> attribute identifies the type of a DBI handle. Returns
+"dr" for driver handles, "db" for database handles and "st" for
+statement handles.
+
+=item C<ChildHandles> (array ref)
+
+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.
+
+For example, to enumerate all driver handles, database handles and
+statement handles:
+
+ sub show_child_handles {
+ my ($h, $level) = @_;
+ $level ||= 0;
+ printf "%sh %s %s\n", $h->{Type}, "\t" x $level, $h;
+ show_child_handles($_, $level + 1)
+ for (grep { defined } @{$h->{ChildHandles}});
+ }
+
+ my %drivers = DBI->installed_drivers();
+ show_child_handles($_) for (values %drivers);
+
=item C<CompatMode> (boolean, inherited)
The C<CompatMode> attribute is used by emulation layers (such as
diff -Naur DBI-1.48.orig/DBI.xs DBI-1.48/DBI.xs
--- DBI-1.48.orig/DBI.xs 2005-01-20 06:06:28.000000000 -0500
+++ DBI-1.48/DBI.xs 2005-06-27 14:25:43.345765384 -0400
@@ -1442,6 +1442,9 @@
DBIc_set(imp_xxh,DBIcf_HandleSetErr, on);
cacheit = 1; /* child copy setup by dbih_setup_handle() */
}
+ else if (strEQ(key, "ChildHandles")) {
+ cacheit = 1; /* just save it in the hash */
+ }
else if (strEQ(key, "Profile")) {
char *dbi_class = "DBI::Profile";
if (on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVHV)) ) {
@@ -1754,6 +1757,15 @@
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));
}
diff -Naur DBI-1.48.orig/lib/DBI/PurePerl.pm DBI-1.48/lib/DBI/PurePerl.pm
--- DBI-1.48.orig/lib/DBI/PurePerl.pm 2004-12-16 11:41:06.000000000 -0500
+++ DBI-1.48/lib/DBI/PurePerl.pm 2005-06-27 14:23:08.429316264 -0400
@@ -143,6 +143,7 @@
Attribution
BegunWork
CachedKids
+ ChildHandles
CursorName
Database
DebugDispatch
@@ -169,6 +170,7 @@
SCALE
Statement
TYPE
+ Type
TraceLevel
Username
Version
@@ -645,6 +647,13 @@
return ($h->FETCH('TaintIn') && $h->FETCH('TaintOut')) if $key
eq'Taint';
return (1==0) if $is_flag_attribute{$key}; # return perl-style sv_no,
not undef
return $DBI::dbi_debug if $key eq 'TraceLevel';
+ return [] if $key eq 'ChildHandles';
+ if ($key eq 'Type') {
+ return "dr" if $h->isa('DBI::dr');
+ return "db" if $h->isa('DBI::db');
+ return "st" if $h->isa('DBI::st');
+ Carp::carp( sprintf "Can't get determine Type for %s",$h );
+ }
if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) {
local $^W; # hide undef warnings
Carp::carp( sprintf "Can't get %s->{%s}: unrecognised attribute
(@{[ %$h ]})",$h,$key )
diff -Naur DBI-1.48.orig/t/71installed_drivers.t
DBI-1.48/t/71installed_drivers.t
--- DBI-1.48.orig/t/71installed_drivers.t 1969-12-31 19:00:00.000000000
-0500
+++ DBI-1.48/t/71installed_drivers.t 2005-06-24 18:08:33.000000000 -0400
@@ -0,0 +1,26 @@
+#!perl -w
+
+use strict;
+
+#
+# test script for the installed_drivers class method
+#
+
+use DBI;
+
+use Test;
+BEGIN { plan tests => 4; }
+
+# installed drivers should start empty
+my %drivers = DBI->installed_drivers();
+ok(scalar keys %drivers, 0);
+
+# make a connection
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+
+# now the driver should be registered
+%drivers = DBI->installed_drivers();
+ok(scalar keys %drivers, 1);
+ok(exists $drivers{ExampleP});
+ok($drivers{ExampleP}->isa('DBI::dr'));
+
diff -Naur DBI-1.48.orig/t/72childhandles.t DBI-1.48/t/72childhandles.t
--- DBI-1.48.orig/t/72childhandles.t 1969-12-31 19:00:00.000000000 -0500
+++ DBI-1.48/t/72childhandles.t 2005-06-27 14:13:26.858728432 -0400
@@ -0,0 +1,95 @@
+#!perl -w
+
+use strict;
+
+#
+# test script for the ChildHandles attribute
+#
+
+use DBI;
+
+use Test;
+BEGIN { plan tests => 22; }
+{
+ # make 10 connections
+ my @dbh;
+ for (1 .. 10) {
+ my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+ push(@dbh, $dbh);
+ }
+
+ # get the driver handle
+ my %drivers = DBI->installed_drivers();
+ my $driver = $drivers{ExampleP};
+ ok($driver);
+
+ # get the kids, should be the 10 connections
+ my $db_handles = $driver->{ChildHandles};
+ ok(scalar @$db_handles, 10);
+
+ # make sure all the handles are there
+ foreach my $h (@dbh) {
+ ok(grep { $h == $_ } @$db_handles);
+ }
+}
+
+# now all the out-of-scope DB handles should be gone
+{
+ my %drivers = DBI->installed_drivers();
+ my $driver = $drivers{ExampleP};
+
+ my $handles = $driver->{ChildHandles};
+ my @db_handles = grep { defined } @$handles;
+ ok(scalar @db_handles, 0);
+}
+
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+
+
+# ChildHandles should start with an empty array-ref
+my $empty = $dbh->{ChildHandles};
+ok(scalar @$empty, 0);
+
+# test child handles for statement handles
+{
+ my @sth;
+ for (1 .. 200) {
+ my $sth = $dbh->prepare('SELECT name FROM t');
+ push(@sth, $sth);
+ }
+ my $handles = $dbh->{ChildHandles};
+ ok(scalar @$handles, 200);
+
+ # test a recursive walk like the one in the docs
+ my @lines;
+ sub show_child_handles {
+ my ($h, $level) = @_;
+ $level ||= 0;
+ push(@lines,
+ sprintf "%sh %s %s\n", $h->{Type}, "\t" x $level, $h);
+ show_child_handles($_, $level + 1)
+ for (grep { defined } @{$h->{ChildHandles}});
+ }
+ show_child_handles($_) for (values %{{DBI->installed_drivers()}});
+
+ ok(scalar @lines, 202);
+ ok($lines[0] =~ /^drh/);
+ ok($lines[1] =~ /^dbh/);
+ ok($lines[2] =~ /^sth/);
+}
+
+# they should be gone now
+my $handles = $dbh->{ChildHandles};
+my @live = grep { defined $_ } @$handles;
+ok(scalar @live, 0);
+
+# test that the childhandle array won't grow uncontrollably.
+{
+ for (1 .. 1000) {
+ my $sth = $dbh->prepare('SELECT name FROM t');
+ }
+ my $handles = $dbh->{ChildHandles};
+ ok(scalar @$handles < 1000);
+ my @live = grep { defined } @$handles;
+ ok(scalar @live, 0);
+}
