Fork safety

.github/workflows/build.yml

@@ -17,7 +17,7 @@ jobs:
       - name: perl -V
         run: perl -V
       - name: Install dependencies
-        run: curl -sL https://git.io/cpm | sudo perl - install -g --with-recommends --with-test --with-configure --show-build-log-on-failure --feature=test_sqlite
+        run: curl -sL https://git.io/cpm | sudo perl - install -g --with-recommends --with-test --with-configure --show-build-log-on-failure --feature=test_sqlite --feature=test_fork
       - name: Run tests
         run: prove -lr -j4 t
 
@@ -31,7 +31,7 @@ jobs:
       - name: apt-get
         run: sudo apt-get update && sudo apt-get install -y libdbd-mysql-perl mysql-server
       - name: Install dependencies
-        run: curl -sL https://git.io/cpm | sudo perl - install -g --with-recommends --with-test --with-configure --show-build-log-on-failure --feature=test_mysql
+        run: curl -sL https://git.io/cpm | sudo perl - install -g --with-recommends --with-test --with-configure --show-build-log-on-failure --feature=test_mysql --feature=test_fork
       - name: Run tests
         run: DOD_TEST_DRIVER=MySQL prove -lr -j4 t
 
@@ -47,7 +47,7 @@ jobs:
       - name: apt-get
         run: sudo apt-get update && sudo apt-get install -y libmariadb-dev mariadb-server
       - name: Install dependencies
-        run: curl -sL https://git.io/cpm | sudo perl - install -g --with-recommends --with-test --with-configure --show-build-log-on-failure --feature=test_mariadb
+        run: curl -sL https://git.io/cpm | sudo perl - install -g --with-recommends --with-test --with-configure --show-build-log-on-failure --feature=test_mariadb --feature=test_fork
       - name: Run tests
         run: DOD_TEST_DRIVER=MariaDB prove -lr -j4 t
 
@@ -61,6 +61,6 @@ jobs:
       - name: apt-get
         run: sudo apt-get update && sudo apt-get install -y libdbd-pg-perl postgresql
       - name: Install dependencies
-        run: curl -sL https://git.io/cpm | sudo perl - install -g --with-recommends --with-test --with-configure --show-build-log-on-failure --feature=test_postgresql
+        run: curl -sL https://git.io/cpm | sudo perl - install -g --with-recommends --with-test --with-configure --show-build-log-on-failure --feature=test_postgresql --feature=test_fork
       - name: Run tests
         run: DOD_TEST_DRIVER=PostgreSQL prove -lr -j4 t

cpanfile

@@ -45,3 +45,11 @@ feature 'test_postgresql', 'Test PostgreSQL' => sub {
     requires 'Test::PostgreSQL';
     requires 'SQL::Translator';
 };
+
+feature 'test_fork', 'Test Fork' => sub {
+    requires 'DBI', '1.614';
+    requires 'Parallel::ForkManager';
+    requires 'POSIX::AtFork';
+    requires 'Scalar::Util';
+    requires 'Test::SharedFork';
+};

lib/Data/ObjectDriver.pm

@@ -758,6 +758,12 @@ has been added specifically for this purpose: C<reuse_dbh>.
 
     1;
 
+=head1 FORK SAFETY
+
+As of version 0.21, I<Data::ObjectDriver> resets internal database handles
+after I<fork(2)> is called, but only if L<POSIX::AtFork> module is installed.
+Otherwise, I<Data::ObjectDriver> is not fork-safe.
+
 =head1 SUPPORTED DATABASES
 
 I<Data::ObjectDriver> is very modular and it's not very difficult to add new drivers.

lib/Data/ObjectDriver/Driver/DBI.pm

@@ -13,6 +13,16 @@ use Data::ObjectDriver::SQL;
 use Data::ObjectDriver::Driver::DBD;
 use Data::ObjectDriver::Iterator;
 
+my $ForkSafe = _is_fork_safe();
+my %Handles;
+
+sub _is_fork_safe {
+    return if exists $ENV{DOD_FORK_SAFE} and !$ENV{DOD_FORK_SAFE};
+    eval { require POSIX::AtFork; 1 } or return;
+    eval { require Scalar::Util; Scalar::Util->import('weaken'); 1 } or return;
+    return 1;
+}
+
 __PACKAGE__->mk_accessors(qw( dsn username password connect_options dbh get_dbh dbd prefix reuse_dbh force_no_prepared_cache));
 
 
@@ -36,6 +46,17 @@ sub init {
         }
         $driver->dbd(Data::ObjectDriver::Driver::DBD->new($type));
     }
+
+    if ($ForkSafe) {
+        # Purge cached handles
+        weaken(my $driver_weaken = $driver);
+        POSIX::AtFork->add_to_child(sub {
+            return unless $driver_weaken;
+            $driver_weaken->dbh(undef);
+            %Handles = ();
+        });
+    }
+
     $driver;
 }
 
@@ -61,7 +82,6 @@ sub _prepare_cached {
     return ($driver->dbd->can_prepare_cached_statements)? $dbh->prepare_cached($sql) : $dbh->prepare($sql);
 }
 
-my %Handles;
 sub init_db {
     my $driver = shift;
     my $dbh;
@@ -72,6 +92,7 @@ sub init_db {
         eval {
             $dbh = DBI->connect($driver->dsn, $driver->username, $driver->password,
                 { RaiseError => 1, PrintError => 0, AutoCommit => 1,
+                ( $ForkSafe ? ( AutoInactiveDestroy => 1 ) : () ),
                 %{$driver->connect_options || {}} })
                 or Carp::croak("Connection error: " . $DBI::errstr);
         };
@@ -669,7 +690,7 @@ sub DESTROY {
     ## if we haven't created it ourself.
     return unless $driver->{__dbh_init_by_driver};
     if (my $dbh = $driver->dbh) {
-        $dbh->disconnect if $dbh;
+        $dbh->disconnect;
     }
 }
 

t/60-fork.t

@@ -0,0 +1,80 @@
+use strict;
+use warnings;
+use lib 't/lib';
+
+$Data::ObjectDriver::DEBUG = 0;
+use Test::More;
+use DodTestUtil;
+
+BEGIN {
+    my @requires = qw(
+        Parallel::ForkManager
+        Test::SharedFork
+    );
+
+    for my $module (@requires) {
+        eval "require $module" or plan skip_all => "requires $module";
+    }
+    DodTestUtil->check_driver;
+}
+
+setup_dbs({
+    global => [ qw( wines ) ],
+});
+
+use Wine;
+
+my $wine = Wine->new;
+$wine->name("Latour");
+ok($wine->save, 'Object saved successfully');
+
+my $wine_id = $wine->id;
+undef $wine;
+$wine = Wine->lookup($wine_id); 
+
+ok $wine;
+
+my $max = $ENV{DOD_TEST_MAX_FORK} || 10;
+my $pm = Parallel::ForkManager->new( $ENV{DOD_TEST_WORKERS} || 4 );
+$pm->run_on_finish(sub {
+    my ($pid, $exit, $ident) = @_;
+    ok !$exit, "pid $pid exits $exit";
+});
+$pm->run_on_start(sub {
+    my ($pid, $ident) = @_;
+    note "pid $pid starts";
+});
+for my $id ( 1 .. $max ) {
+    my $pid = $pm->start and next;
+    my $new_wine = Wine->new;
+    $new_wine->name("Wine $id");
+    $new_wine->begin_work;
+    ok $new_wine->save, "saved wine $id";
+    $new_wine->commit;
+
+    my ($result) = Wine->result({name => 'Latour'});
+    ok !$result->is_finished, "not yet finished";
+    ok my $latour = $result->next, "next";
+    is $latour->name => 'Latour', "found Latour";
+    ok !$result->next, "no more next";
+    ok $result->is_finished, "finished";
+
+    $pm->finish;
+}
+
+$pm->wait_all_children;
+
+pass("waited all children");
+
+my $result = Wine->result({});
+my %seen;
+while( my $wine = $result->next ) {
+    $seen{$wine->name} = 1;
+}
+
+ok $seen{Latour}, "seen Latour";
+ok $seen{"Wine $_"}, "seen Wine $_" for 1 .. $max;
+
+done_testing;
+
+teardown_dbs('global');

t/lib/DodTestUtil.pm

@@ -95,7 +95,8 @@ CONF
         return $TestDB{$dbname}->dsn;
     }
     if ( $driver eq 'SQLite' ) {
-        return 'dbi:SQLite:' . db_filename($dbname);
+        $TestDB{$dbname} ||= db_filename($dbname);
+        return 'dbi:SQLite:' . $TestDB{$dbname};
     }
 }
 
@@ -118,11 +119,11 @@ sub setup_dbs {
 sub teardown_dbs {
     my(@dbs) = @_;
     my $driver = driver();
+    return unless $driver eq 'SQLite';
     for my $db (@dbs) {
-        next unless $driver eq 'SQLite';
-        my $file = db_filename($db);
+        my $file = $TestDB{$db};
         next unless -e $file;
-        unlink $file or die "Can't teardown $db: $!";
+        unlink $file or die "Can't teardown $file: $!";
     }
 }