Move the Subclassing POD under Examples
[dbsrgits/DBIx-Class.git] / t / 50fork.t
1 use strict;
2 use warnings;
3 use Test::More;
4 use Test::Exception;
5
6 use lib qw(t/lib);
7 use DBICTest;
8 use DBIx::Class::Optional::Dependencies ();
9
10 my $main_pid = $$;
11
12 plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg')
13   unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg');
14
15 my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/};
16
17 plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test'
18       . ' (note: creates and drops a table named artist!)' unless ($dsn && $user);
19
20 # README: If you set the env var to a number greater than 10,
21 #   we will use that many children
22 my $num_children = $ENV{DBICTEST_FORK_STRESS} || 1;
23 if($num_children !~ /^[0-9]+$/ || $num_children < 10) {
24    $num_children = 10;
25 }
26
27 my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1 });
28
29 my $parent_rs;
30
31 eval {
32     my $dbh = $schema->storage->dbh;
33
34     {
35         local $SIG{__WARN__} = sub {};
36         eval { $dbh->do("DROP TABLE cd") };
37         $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);");
38     }
39
40     $schema->resultset('CD')->create({ title => 'vacation in antarctica', artist => 123, year => 1901 });
41     $schema->resultset('CD')->create({ title => 'vacation in antarctica part 2', artist => 456, year => 1901 });
42
43     $parent_rs = $schema->resultset('CD')->search({ year => 1901 });
44     is ($parent_rs->count, 2);
45 };
46 ok(!$@) or diag "Creation eval failed: $@";
47
48 # basic tests
49 {
50   ok ($schema->storage->connected(), 'Parent is connected');
51   is ($parent_rs->next->id, 1, 'Cursor advanced');
52
53   my ($parent_in, $child_out);
54   pipe( $parent_in, $child_out ) or die "Pipe open failed: $!";
55
56   my $pid = fork;
57   if(!defined $pid) {
58     die "fork failed: $!";
59   }
60
61   if (!$pid) {
62     close $parent_in;
63
64     #simulate a  subtest to not confuse the parent TAP emission
65     my $tb = Test::More->builder;
66     $tb->reset;
67     for (qw/output failure_output todo_output/) {
68       close $tb->$_;
69       open ($tb->$_, '>&', $child_out);
70     }
71
72     ok(!$schema->storage->connected, "storage->connected() false in child");
73     for (1,2) {
74       throws_ok { $parent_rs->next } qr/\QMulti-process access attempted while cursor in progress (position 1)/;
75     }
76
77     $parent_rs->reset;
78     is($parent_rs->next->id, 1, 'Resetting cursor reprepares it within child environment');
79
80     done_testing;
81     exit 0;
82   }
83
84   close $child_out;
85   while (my $ln = <$parent_in>) {
86     print "   $ln";
87   }
88   waitpid( $pid, 0 );
89   ok(!$?, 'Child subtests passed');
90
91   is ($parent_rs->next->id, 2, 'Cursor still intact in parent');
92   is ($parent_rs->next, undef, 'Cursor exhausted');
93 }
94
95 $parent_rs->reset;
96 my @pids;
97 while(@pids < $num_children) {
98
99     my $pid = fork;
100     if(!defined $pid) {
101         die "fork failed: $!";
102     }
103     elsif($pid) {
104         push(@pids, $pid);
105         next;
106     }
107
108     $pid = $$;
109
110     my $work = sub {
111       my $child_rs = $schema->resultset('CD')->search({ year => 1901 });
112       my $row = $parent_rs->next;
113       $schema->resultset('CD')->create({ title => "test success $pid", artist => $pid, year => scalar(@pids) })
114         if($row && $row->get_column('artist') =~ /^(?:123|456)$/);
115     };
116
117     # try with and without transactions
118     if ((@pids % 3) == 1) {
119       my $guard = $schema->txn_scope_guard;
120       $work->();
121       $guard->commit;
122     }
123     elsif ((@pids % 3) == 2) {
124       $schema->txn_do ($work);
125     }
126     else {
127       $work->();
128     }
129
130     sleep(3);
131     exit 0;
132 }
133
134 ok(1, "past forking");
135
136 for (@pids) {
137   waitpid($_,0);
138   ok (! $?, "Child $_ exitted cleanly");
139 };
140
141 ok(1, "past waiting");
142
143 while(@pids) {
144     my $pid = pop(@pids);
145     my $rs = $schema->resultset('CD')->search({ title => "test success $pid", artist => $pid, year => scalar(@pids) });
146     is($rs->next->get_column('artist'), $pid, "Child $pid successful");
147 }
148
149 ok(1, "Made it to the end");
150
151 done_testing;
152
153 END {
154   $schema->storage->dbh->do("DROP TABLE cd") if ($schema and $main_pid == $$);
155   undef $schema;
156 }