I'm using DBI 1.53, Perl 5.8.8, and PostgreSQL.
#!/usr/bin/perl
use strict;
use warnings;
use Test::More 'no_plan';
use DBI;
my @connect_parameters
= ( 'DBI:Pg:dbname=template1', 'user', 'pass',
{ ShowErrorStatement => 1,
AutoCommit => 1,
RaiseError => 1,
PrintError => 0, } );
# An earlier version leaked socket connections
# and would eventually fail (or cause "Too many
# open files" errors elsewhere). I loop a while
# here to detect that bug.
foreach my $iteration ( 1 .. 2_000 ) {
warn "iteration $iteration\n";
my $dbh = DBI->connect( @connect_parameters );
isa_ok( $dbh, 'DBI::db' );
my $one;
($one) = $dbh->selectrow_array( 'SELECT 1' );
is( $one, 1, 'can select 1' );
# this is fetched later
my $sth = $dbh->prepare( 'SELECT 1' );
$sth->execute;
ok( ! $dbh->{InactiveDestroy},
'dbh InactiveDestroy is off before fork' );
my $pid = fork();
if ( ! defined $pid ) {
die "Can't fork: $!\n";
}
if ( $pid ) {
# parent
isa_ok( $dbh, 'DBI::db' );
($one) = $dbh->selectrow_array( 'SELECT 1' );
is( $one, 1, 'parent can select 1 before child exits' );
is( wait(), $pid, 'waited for child' );
($one) = $dbh->selectrow_array( 'SELECT 1' );
is( $one, 1, 'parent can select 1 after child exits' );
}
else {
# child
my $child_dbh = $dbh->clone();
isa_ok( $dbh, 'DBI::db' );
isa_ok( $child_dbh, 'DBI::db' );
ok( ! $dbh->{InactiveDestroy},
'dbh InactiveDestroy is off in child after fork' );
ok( ! $child_dbh->{InactiveDestroy},
'child_dbh InactiveDestroy is off in child after fork' );
$dbh->{InactiveDestroy} = 1;
ok( $dbh->{InactiveDestroy},
'dbh InactiveDestroy is on in child after fork' );
ok( ! $child_dbh->{InactiveDestroy},
'child_dbh InactiveDestroy is off in child after fork' );
undef $dbh;
ok( ! $dbh, 'death to dbh in child' );
($one) = $child_dbh->selectrow_array( 'SELECT 1' );
is( $one, 1, 'child can select 1' );
exit;
}
($one) = $sth->fetchrow_array;
is( $one, 1, 'select running before fork still works' );
}
The clone call produces one warning that doesn't seem to have any consequence:
Can't set DBI::db=HASH(0x8424abc)->{User}: unrecognised attribute name or invalid value at /usr/lib/perl5/DBI.pm line 675.
In production code, I handle this with a $SIG{__WARN__} handler like so:
# Save existing handler.
my $saved_warn_handler = $SIG{__WARN__};
# Suppress warnings.
$SIG{__WARN__} = sub {};
my $child_dbh = $dbh->clone();
# Restore saved handler.
$SIG{__WARN__} = $saved_warn_handler;