Skip to content

Commit c73dfda

Browse files
comewalkcomewalk
authored
Merge pull request #40 from charsbar/fork_safety
Fork safety
2 parents e80e145 + a1be08c commit c73dfda

6 files changed

Lines changed: 126 additions & 10 deletions

File tree

‎.github/workflows/build.yml‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ jobs:
1717
- name: perl -V
1818
run: perl -V
1919
- name: Install dependencies
20-
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
20+
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
2121
- name: Run tests
2222
run: prove -lr -j4 t
2323

@@ -31,7 +31,7 @@ jobs:
3131
- name: apt-get
3232
run: sudo apt-get update && sudo apt-get install -y libdbd-mysql-perl mysql-server
3333
- name: Install dependencies
34-
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
34+
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
3535
- name: Run tests
3636
run: DOD_TEST_DRIVER=MySQL prove -lr -j4 t
3737

@@ -47,7 +47,7 @@ jobs:
4747
- name: apt-get
4848
run: sudo apt-get update && sudo apt-get install -y libmariadb-dev mariadb-server
4949
- name: Install dependencies
50-
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
50+
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
5151
- name: Run tests
5252
run: DOD_TEST_DRIVER=MariaDB prove -lr -j4 t
5353

@@ -61,6 +61,6 @@ jobs:
6161
- name: apt-get
6262
run: sudo apt-get update && sudo apt-get install -y libdbd-pg-perl postgresql
6363
- name: Install dependencies
64-
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
64+
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
6565
- name: Run tests
6666
run: DOD_TEST_DRIVER=PostgreSQL prove -lr -j4 t

‎cpanfile‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,3 +45,11 @@ feature 'test_postgresql', 'Test PostgreSQL' => sub {
4545
requires 'Test::PostgreSQL';
4646
requires 'SQL::Translator';
4747
};
48+
49+
feature 'test_fork', 'Test Fork' => sub {
50+
requires 'DBI', '1.614';
51+
requires 'Parallel::ForkManager';
52+
requires 'POSIX::AtFork';
53+
requires 'Scalar::Util';
54+
requires 'Test::SharedFork';
55+
};

‎lib/Data/ObjectDriver.pm‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -758,6 +758,12 @@ has been added specifically for this purpose: C<reuse_dbh>.
758758
759759
1;
760760
761+
=head1 FORK SAFETY
762+
763+
As of version 0.21, I<Data::ObjectDriver> resets internal database handles
764+
after I<fork(2)> is called, but only if L<POSIX::AtFork> module is installed.
765+
Otherwise, I<Data::ObjectDriver> is not fork-safe.
766+
761767
=head1 SUPPORTED DATABASES
762768
763769
I<Data::ObjectDriver> is very modular and it's not very difficult to add new drivers.

‎lib/Data/ObjectDriver/Driver/DBI.pm‎

Lines changed: 23 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,16 @@ use Data::ObjectDriver::SQL;
1313
use Data::ObjectDriver::Driver::DBD;
1414
use Data::ObjectDriver::Iterator;
1515

16+
my $ForkSafe = _is_fork_safe();
17+
my %Handles;
18+
19+
sub _is_fork_safe {
20+
return if exists $ENV{DOD_FORK_SAFE} and !$ENV{DOD_FORK_SAFE};
21+
eval { require POSIX::AtFork; 1 } or return;
22+
eval { require Scalar::Util; Scalar::Util->import('weaken'); 1 } or return;
23+
return 1;
24+
}
25+
1626
__PACKAGE__->mk_accessors(qw( dsn username password connect_options dbh get_dbh dbd prefix reuse_dbh force_no_prepared_cache));
1727

1828

@@ -36,6 +46,17 @@ sub init {
3646
}
3747
$driver->dbd(Data::ObjectDriver::Driver::DBD->new($type));
3848
}
49+
50+
if ($ForkSafe) {
51+
# Purge cached handles
52+
weaken(my $driver_weaken = $driver);
53+
POSIX::AtFork->add_to_child(sub {
54+
return unless $driver_weaken;
55+
$driver_weaken->dbh(undef);
56+
%Handles = ();
57+
});
58+
}
59+
3960
$driver;
4061
}
4162

@@ -61,7 +82,6 @@ sub _prepare_cached {
6182
return ($driver->dbd->can_prepare_cached_statements)? $dbh->prepare_cached($sql) : $dbh->prepare($sql);
6283
}
6384

64-
my %Handles;
6585
sub init_db {
6686
my $driver = shift;
6787
my $dbh;
@@ -72,6 +92,7 @@ sub init_db {
7292
eval {
7393
$dbh = DBI->connect($driver->dsn, $driver->username, $driver->password,
7494
{ RaiseError => 1, PrintError => 0, AutoCommit => 1,
95+
( $ForkSafe ? ( AutoInactiveDestroy => 1 ) : () ),
7596
%{$driver->connect_options || {}} })
7697
or Carp::croak("Connection error: " . $DBI::errstr);
7798
};
@@ -669,7 +690,7 @@ sub DESTROY {
669690
## if we haven't created it ourself.
670691
return unless $driver->{__dbh_init_by_driver};
671692
if (my $dbh = $driver->dbh) {
672-
$dbh->disconnect if $dbh;
693+
$dbh->disconnect;
673694
}
674695
}
675696

‎t/60-fork.t‎

Lines changed: 80 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,80 @@
1+
use strict;
2+
use warnings;
3+
use lib 't/lib';
4+
5+
$Data::ObjectDriver::DEBUG = 0;
6+
use Test::More;
7+
use DodTestUtil;
8+
9+
BEGIN {
10+
my @requires = qw(
11+
Parallel::ForkManager
12+
Test::SharedFork
13+
);
14+
15+
for my $module (@requires) {
16+
eval "require $module" or plan skip_all => "requires $module";
17+
}
18+
DodTestUtil->check_driver;
19+
}
20+
21+
setup_dbs({
22+
global => [ qw( wines ) ],
23+
});
24+
25+
use Wine;
26+
27+
my $wine = Wine->new;
28+
$wine->name("Latour");
29+
ok($wine->save, 'Object saved successfully');
30+
31+
my $wine_id = $wine->id;
32+
undef $wine;
33+
$wine = Wine->lookup($wine_id);
34+
35+
ok $wine;
36+
37+
my $max = $ENV{DOD_TEST_MAX_FORK} || 10;
38+
my $pm = Parallel::ForkManager->new( $ENV{DOD_TEST_WORKERS} || 4 );
39+
$pm->run_on_finish(sub {
40+
my ($pid, $exit, $ident) = @_;
41+
ok !$exit, "pid $pid exits $exit";
42+
});
43+
$pm->run_on_start(sub {
44+
my ($pid, $ident) = @_;
45+
note "pid $pid starts";
46+
});
47+
for my $id ( 1 .. $max ) {
48+
my $pid = $pm->start and next;
49+
my $new_wine = Wine->new;
50+
$new_wine->name("Wine $id");
51+
$new_wine->begin_work;
52+
ok $new_wine->save, "saved wine $id";
53+
$new_wine->commit;
54+
55+
my ($result) = Wine->result({name => 'Latour'});
56+
ok !$result->is_finished, "not yet finished";
57+
ok my $latour = $result->next, "next";
58+
is $latour->name => 'Latour', "found Latour";
59+
ok !$result->next, "no more next";
60+
ok $result->is_finished, "finished";
61+
62+
$pm->finish;
63+
}
64+
65+
$pm->wait_all_children;
66+
67+
pass("waited all children");
68+
69+
my $result = Wine->result({});
70+
my %seen;
71+
while( my $wine = $result->next ) {
72+
$seen{$wine->name} = 1;
73+
}
74+
75+
ok $seen{Latour}, "seen Latour";
76+
ok $seen{"Wine $_"}, "seen Wine $_" for 1 .. $max;
77+
78+
done_testing;
79+
80+
teardown_dbs('global');

‎t/lib/DodTestUtil.pm‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -95,7 +95,8 @@ CONF
9595
return $TestDB{$dbname}->dsn;
9696
}
9797
if ( $driver eq 'SQLite' ) {
98-
return 'dbi:SQLite:' . db_filename($dbname);
98+
$TestDB{$dbname} ||= db_filename($dbname);
99+
return 'dbi:SQLite:' . $TestDB{$dbname};
99100
}
100101
}
101102

@@ -118,11 +119,11 @@ sub setup_dbs {
118119
sub teardown_dbs {
119120
my(@dbs) = @_;
120121
my $driver = driver();
122+
return unless $driver eq 'SQLite';
121123
for my $db (@dbs) {
122-
next unless $driver eq 'SQLite';
123-
my $file = db_filename($db);
124+
my $file = $TestDB{$db};
124125
next unless -e $file;
125-
unlink $file or die "Can't teardown $db: $!";
126+
unlink $file or die "Can't teardown $file: $!";
126127
}
127128
}
128129

0 commit comments

Comments
 (0)