X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F50fork.t;h=229a4f249da518bff846d0e24bdee5fb750af6e5;hb=c33d5ebc4d84e4338f269565f6fe011801cb9fd4;hp=0e40c6a9e25aad8d9344a6b8886549c059d714f5;hpb=474ab91c448ffd9758cdd6a1f7b266e9610dcbfd;p=dbsrgits%2FDBIx-Class.git diff --git a/t/50fork.t b/t/50fork.t index 0e40c6a..229a4f2 100644 --- a/t/50fork.t +++ b/t/50fork.t @@ -1,44 +1,99 @@ -use Class::C3; +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +use DBIx::Class::Optional::Dependencies -skip_all_without => 'test_rdbms_pg'; + use strict; -use Test::More; use warnings; +use Test::More; +use Test::Exception; +use Time::HiRes qw(time sleep); +use List::Util 'max'; + +use DBICTest; -# This test passes no matter what in most cases. However, prior to the recent -# fork-related fixes, it would spew lots of warnings. I have not quite gotten -# it to where it actually fails in those cases. +my $main_pid = $$; + +# README: If you set the env var to a number greater than 5, +# we will use that many children +my $num_children = $ENV{DBICTEST_FORK_STRESS} || 1; +if($num_children !~ /^[0-9]+$/ || $num_children < 5) { + $num_children = 5; +} my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; +my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1 }); -plan skip_all => 'Set $ENV{DBICTEST_FORK_STRESS} to run this test' - unless $ENV{DBICTEST_FORK_STRESS}; +my $parent_rs; -plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test' - . ' (note: creates and drops a table named artist!)' unless ($dsn && $user); +eval { + my $dbh = $schema->storage->dbh; -plan tests => 15; + { + local $SIG{__WARN__} = sub {}; + eval { $dbh->do("DROP TABLE cd") }; + $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(100) NOT NULL UNIQUE, year VARCHAR(100) NOT NULL, genreid INTEGER, single_track INTEGER);"); + } -use lib qw(t/lib); + $schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 }); + $schema->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 }); -use_ok('DBICTest::Schema'); + $parent_rs = $schema->resultset('CD')->search({ year => 1901 }); + is ($parent_rs->count, 2); +}; +ok(!$@) or diag "Creation eval failed: $@"; -DBICTest::Schema->compose_connection('PgTest' => $dsn, $user, $pass, { AutoCommit => 1 }); +# basic tests +{ + ok ($schema->storage->connected(), 'Parent is connected'); + is ($parent_rs->next->id, 1, 'Cursor advanced'); -my ($first_rs, $joe_record); + my ($parent_in, $child_out); + pipe( $parent_in, $child_out ) or die "Pipe open failed: $!"; -eval { - my $dbh = PgTest->schema->storage->dbh; + my $pid = fork; + if(!defined $pid) { + die "fork failed: $!"; + } - $dbh->do("CREATE TABLE cd (cdid serial PRIMARY KEY, artist INTEGER NOT NULL UNIQUE, title VARCHAR(255) NOT NULL UNIQUE, year VARCHAR(255));"); + if (!$pid) { + close $parent_in; - PgTest->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 }); - PgTest->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 }); + #simulate a subtest to not confuse the parent TAP emission + my $tb = Test::More->builder; + $tb->reset; + for (qw/output failure_output todo_output/) { + close $tb->$_; + open ($tb->$_, '>&', $child_out); + } - $first_rs = PgTest->resultset('CD')->search({ year => 1901 }); - $joe_record = $first_rs->next; -}; -ok(!$@) or diag "Creation eval failed: $@"; + ok(!$schema->storage->connected, "storage->connected() false in child"); + for (1,2) { + throws_ok { $parent_rs->next } qr/\QMulti-process access attempted while cursor in progress (position 1)/; + } + + $parent_rs->reset; + is($parent_rs->next->id, 1, 'Resetting cursor reprepares it within child environment'); + + done_testing; + exit 0; + } + + close $child_out; + while (my $ln = <$parent_in>) { + print " $ln"; + } + waitpid( $pid, 0 ); + ok(!$?, 'Child subtests passed'); + + is ($parent_rs->next->id, 2, 'Cursor still intact in parent'); + is ($parent_rs->next, undef, 'Cursor exhausted'); +} + +$parent_rs->reset; + +# sleep until this spot so everything starts simultaneously +# add "until turn of second" for prettier display +my $t = int( time() ) + 4; -my $num_children = 10; my @pids; while(@pids < $num_children) { @@ -48,33 +103,58 @@ while(@pids < $num_children) { } elsif($pid) { push(@pids, $pid); - next; + next; } $pid = $$; - my ($forked_rs, $joe_forked); - $forked_rs = PgTest->resultset('CD')->search({ year => 1901 }); - $joe_forked = $first_rs->next; - if($joe_forked && $joe_forked->get_column('artist') =~ /^(?:123|456)$/) { - PgTest->resultset('CD')->create({ title => "test success $pid", artist => $pid, year => scalar(@pids) }); + sleep( max( 0.1, $t - time ) ); + note ("Child process $pid starting work at " . time() ); + + my $work = sub { + my $child_rs = $schema->resultset('CD')->search({ year => 1901 }); + my $row = $parent_rs->next; + $schema->resultset('CD')->create({ title => "test success $pid", artist => $pid, year => scalar(@pids) }) + if($row && $row->get_column('artist') =~ /^(?:123|456)$/); + }; + + # try with and without transactions + if ((@pids % 3) == 1) { + my $guard = $schema->txn_scope_guard; + $work->(); + $guard->commit; + } + elsif ((@pids % 3) == 2) { + $schema->txn_do ($work); } - sleep(3); - exit; + else { + $work->(); + } + + sleep(2); + exit 0; } ok(1, "past forking"); -waitpid($_,0) for(@pids); +for (@pids) { + waitpid($_,0); + ok (! $?, "Child $_ exitted cleanly"); +}; ok(1, "past waiting"); while(@pids) { my $pid = pop(@pids); - my $rs = PgTest->resultset('CD')->search({ title => "test success $pid", artist => $pid, year => scalar(@pids) }); + my $rs = $schema->resultset('CD')->search({ title => "test success $pid", artist => $pid, year => scalar(@pids) }); is($rs->next->get_column('artist'), $pid, "Child $pid successful"); } ok(1, "Made it to the end"); -PgTest->schema->storage->dbh->do("DROP TABLE cd"); +done_testing; + +END { + $schema->storage->dbh->do("DROP TABLE cd") if ($schema and $main_pid == $$); + undef $schema; +}