http://www.perlmonks.org?node_id=594175

Some time ago, I wanted to fork a script that had an open DBI connection and a running statement and let the child use the connection the parent had (or an identical connection). This turned out to have more pitfalls than I expected. Everything that is necessary to do this is documented, but I haven't seen one code sample that brings it all together, so I'm documenting here the method I used in the form of a Test::More script.

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;

In summary, the general procedure here is as follows:

  1. You have a $dbh.
  2. fork
  3. Parent goes about its business.
  4. Child creates a new $child_dbh with $dbh->clone().
  5. Child sets $dbh->{InactiveDestroy} = 1. This tells DBI that the parent's connection should not be closed when $dbh is destroyed.
  6. Child destroys parent's $dbh (don't use it on accident!)
  7. Child goes about its business (using $child_dbh as it likes).

Earlier nodes that touch on this subject: