1 files changed, 149 insertions, 0 deletions
diff --git a/t/72childhandles.t b/t/72childhandles.t
new file mode 100644
index 0000000..48fbe37
--- /dev/null
+++ b/t/72childhandles.t
@@ -0,0 +1,149 @@
+#!perl -w
+$|=1;
+
+use strict;
+
+#
+# test script for the ChildHandles attribute
+#
+
+use DBI;
+
+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 = [] ); # same test as in DBI.pm
+    1;
+};
+if (!$HAS_WEAKEN) {
+    chomp $@;
+    print "1..0 # Skipped: Scalar::Util::weaken not available ($@)\n";
+    exit 0;
+}
+
+plan tests => 16;
+
+my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i;
+
+my $drh;
+
+{
+    # make 10 connections
+    my @dbh;
+    for (1 .. 10) {
+        my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+        push @dbh, $dbh;
+    }
+    
+    # get the driver handle
+    $drh = $dbh[0]->{Driver};
+    ok $drh;
+
+    # get the kids, should be the same list of connections
+    my $db_handles = $drh->{ChildHandles};
+    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) {
+        ++$found if grep { $h == $_ } @$db_handles;
+    }
+    is $found, scalar @dbh;
+}
+
+# now all the out-of-scope DB handles should be gone
+{
+    my $handles = $drh->{ChildHandles};
+    my @db_handles = grep { defined } @$handles;
+    is scalar @db_handles, 0, "All handles should be undef now";
+}
+
+my $dbh = DBI->connect("dbi:ExampleP:", '', '', { RaiseError=>1 });
+
+my $empty = $dbh->{ChildHandles};
+is_deeply $empty, [], "ChildHandles should be an array-ref if wekref is available";
+
+# test child handles for statement handles
+{
+    my @sth;
+    my $sth_count = 20;
+    for (1 .. $sth_count) {
+        my $sth = $dbh->prepare('SELECT name FROM t');
+        push @sth, $sth;
+    }
+    my $handles = $dbh->{ChildHandles};
+    is scalar @$handles, scalar @sth;
+
+    # 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}});
+    }   
+    my $drh = $dbh->{Driver};
+    show_child_handles($drh, 0);
+    print @lines[0..4];
+
+    is scalar @lines, $sth_count + 2;
+    like $lines[0], qr/^drh/;
+    like $lines[1], qr/^dbh/;
+    like $lines[2], qr/^sth/;
+}
+
+my $handles = $dbh->{ChildHandles};
+my @live = grep { defined $_ } @$handles;
+is scalar @live, 0, "handles should be gone now";
+
+# test visit_child_handles
+{
+    my $info;
+    my $visitor = sub {
+        my ($h, $info) = @_;
+        my $type = $h->{Type};
+        ++$info->{ $type }{ ($type eq 'st') ? $h->{Statement} : $h->{Name} };
+        return $info;
+    };
+    DBI->visit_handles($visitor, $info = {});
+    is_deeply $info, {
+        'dr' => {
+            'ExampleP' => 1,
+            ($using_dbd_gofer) ? (Gofer => 1) : ()
+        },
+        'db' => { '' => 1 },
+    };
+
+    my $sth1 = $dbh->prepare('SELECT name FROM t');
+    my $sth2 = $dbh->prepare('SELECT name FROM t');
+    DBI->visit_handles($visitor, $info = {});
+    is_deeply $info, {
+        'dr' => {
+            'ExampleP' => 1,
+            ($using_dbd_gofer) ? (Gofer => 1) : ()
+        },
+        'db' => { '' => 1 },
+        'st' => { 'SELECT name FROM t' => 2 }
+    };
+
+}
+
+# test that the childhandle array does not grow uncontrollably
+SKIP: {
+    skip "slow tests avoided when using DBD::Gofer", 2 if $using_dbd_gofer;
+
+    for (1 .. 1000) {
+        my $sth = $dbh->prepare('SELECT name FROM t');
+    }
+    my $handles = $dbh->{ChildHandles};
+    cmp_ok scalar @$handles, '<', 1000;
+    my @live = grep { defined } @$handles;
+    is scalar @live, 0;
+}
+
+1;