On Thu, 23 Jun 2005, Sam Tregar wrote:
> That looks do-able. I'll try to work up a patch in the next couple
> days. I'll include the DBI->installed_drivers() method as well, if
> that's ok.
Here it is. I've implemented a ChildHandles attribute and the
installed_drivers() method. There is one bug left, marked "BROKEN" in
the test script. It concerns what happens when you try to retrieve
ChildHandles for a handle that doesn't have any children. Right now
you get an error like this:
Can't get DBI::db=HASH(0x9bd53bc)->{ChildHandles}: unrecognised
attribute at /home/sam/module-dev/DBI-1.48/blib/lib/DBD/ExampleP.pm
line 221.
I'm sure I could fix this by adding ChildHandles to the list of
attributes in DBI.xs, but you said you didn't think that would be
necessary. Ideas?
-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-25 12:14:25.352097808 -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,26 @@
# 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 (the easy way to do
+ # this with grep undoes the weak-refs, for some reason)
+ if (@$handles % 120 == 0 and @$handles) {
+ my $last = $#$handles;
+ for my $i (0 .. $#$handles) {
+ last if $i > $last;
+ next if defined $handles->[$i];
+ splice @$handles, $i, 1;
+ $last--;
+ }
+ }
+
+ push @$handles, $h;
+ Scalar::Util::weaken($handles->[-1]);
+ }
+
return $h unless wantarray;
($h, $i);
}
@@ -2700,6 +2730,11 @@
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 hash mapping driver names to driver handles.
=item C<installed_versions>
@@ -3275,6 +3310,31 @@
driver handle, returns a reference to the cache (hash) of
database handles created by the L</connect_cached> method.
+=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:
+
+ my %drivers = DBI->installed_drivers();
+ foreach my $drh (values %drivers) {
+ print "DRH: $drh\n";
+ foreach my $dbh (@{$drh->{ChildHandles}}) {
+ next unless defined $dbh;
+ print "DBH: $dbh\n";
+ foreach my $sth (@{$dbh->{ChildHandles}}) {
+ next unless defined $sth;
+ print "STH: $sth\n";
+ }
+ }
+ }
+
=item C<CompatMode> (boolean, inherited)
The C<CompatMode> attribute is used by emulation layers (such as
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-24 20:11:21.170372464 -0400
@@ -0,0 +1,80 @@
+#!perl -w
+
+use strict;
+
+#
+# test script for the ChildHandles attribute
+#
+
+use DBI;
+
+use Test;
+BEGIN { plan tests => 17; }
+{
+ # 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 });
+
+
+##### BROKEN ##### BROKEN ##### BROKEN ##### BROKEN ##### BROKEN
+# ChildHandles should start empty
+# my $empty = $dbh->{ChildHandles};
+# ok(scalar @$empty, 0);
+##### BROKEN ##### BROKEN ##### BROKEN ##### BROKEN ##### BROKEN
+
+# 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);
+}
+
+# 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);
+}
