Here's my first pass at an ActiveHandles attribute. With this patch
this code prints all live handles:
foreach my $handle (@{$dbh->{ActiveHandles}}) {
next unless defined $handle;
print $handle, "\n";
}
I'd like to take the next step and add a DBI->ActiveHandles call to do
it without a $dbh. Alternately we could just document the global
($DBI::active_handles) which offers the same functionality.
Question: is "active" the right word here? Looking at the other
"active" attributes I think maybe not. Perhaps "LiveHandles"?
-samdiff -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-22 13:31:01.904208160 -0400
@@ -271,8 +271,18 @@
DBI->trace_msg("DBI connect via $DBI::connect_via in
$INC{'Apache/DBI.pm'}\n");
}
+# check for weaken support, used by ActiveHandles
+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
+$DBI::active_handles = []; # keeps list of weak-refs to created handles
+
# Setup special DBI dynamic variables. See DBI::var::FETCH for details.
# These are dynamically associated with the last handle used.
tie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA
list
@@ -1166,6 +1176,12 @@
# Now add magic so DBI method dispatch works
DBI::_setup_handle($h, $imp_class, $parent, $imp_data);
+ # store a weakref in ActiveHandles if possible
+ if ($HAS_WEAKEN) {
+ push @$DBI::active_handles, $h;
+ Scalar::Util::weaken($DBI::active_handles->[-1]);
+ }
+
return $h unless wantarray;
($h, $i);
}
@@ -3679,6 +3695,21 @@
The C<Profile> attribute was added in DBI 1.24.
+=item C<ActiveHandles> (global, read-only)
+
+The C<ActiveHandles> attribute contains a reference to an array of all
+the database handles currently live in your program. The references
+on this list are weak-refs (see L<Scalar::Util> for details) which
+means they will become C<undef> when the handle goes out of scope in
+your code.
+
+Example code to print out all available handles:
+
+ foreach my $handle (@{$dbh->{ActiveHandles}}) {
+ next unless defined $handle;
+ print $handle, "\n";
+ }
+
=item C<private_your_module_name_*>
The DBI provides a way to store extra information in a DBI handle 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-22 12:33:15.000000000 -0400
@@ -1548,6 +1548,9 @@
) ) {
cacheit = 1;
}
+ else if (strEQ(key, "ActiveHandles")) {
+ croak("Can't set read-only ActiveHandles attribute.");
+ }
else { /* XXX should really be an event ? */
if (isUPPER(*key)) {
char *msg = "Can't set %s->{%s}: unrecognised attribute or invalid
value%s";
@@ -1739,6 +1742,11 @@
else if (keylen==10 && strEQ(key, "ActiveKids")) {
valuesv = newSViv(DBIc_ACTIVE_KIDS(imp_xxh));
}
+ else if (keylen==13 && strEQ(key, "ActiveHandles")) {
+ // return the global $DBI::active_handles array-ref
+ valuesv = perl_get_sv("DBI::active_handles", 0);
+ SvREFCNT_inc(valuesv);
+ }
break;
case 'B':
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-22 13:29:39.195781752 -0400
@@ -645,6 +645,7 @@
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 $DBI::active_handles if $key eq 'ActiveHandles';
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/71activehandles.t DBI-1.48/t/71activehandles.t
--- DBI-1.48.orig/t/71activehandles.t 1969-12-31 19:00:00.000000000 -0500
+++ DBI-1.48/t/71activehandles.t 2005-06-22 13:21:02.982258136 -0400
@@ -0,0 +1,54 @@
+#!perl -w
+
+use strict;
+
+#
+# test script for the ActiveHandles attribute
+#
+
+use DBI;
+
+use Test;
+BEGIN { plan tests => 15; }
+
+# make one connection to keep around
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+
+{
+ # make 10 connections
+ my @dbh;
+ for (1 .. 10) {
+ my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+ push(@dbh, $dbh);
+ }
+
+ # get them back from ActiveHandles
+ my $handles = $dbh->{ActiveHandles};
+
+ # there should be 11 DB handles, the one at the top and the 10 new ones
+ my @db_handles = grep { $_->isa('DBI::db') } @$handles;
+ ok(scalar @db_handles, 11);
+
+ # make sure all the handles are there
+ foreach my $h (@dbh, $dbh) {
+ ok(grep { $h == $_ } @db_handles);
+ }
+}
+
+# now all the out-of-scope DB handles should be gone
+{
+ my $handles = $dbh->{ActiveHandles};
+ my @db_handles = grep { defined and $_->isa('DBI::db') } @$handles;
+ ok(scalar @db_handles, 1);
+}
+
+# do an explicit disconnect
+$dbh->disconnect;
+
+# it should still be there
+{
+ my $handles = $dbh->{ActiveHandles};
+ my @db_handles = grep { defined and $_->isa('DBI::db') } @$handles;
+ ok(scalar @db_handles, 1);
+ ok(not $db_handles[0]->{Active});
+}
