#!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;