Commit | Line | Data |
c0329273 |
1 | BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } |
2 | |
a4367b26 |
3 | use Config; |
4 | BEGIN { |
5 | unless ($Config{useithreads}) { |
6 | print "1..0 # SKIP your perl does not support ithreads\n"; |
7 | exit 0; |
8 | } |
f15baf68 |
9 | |
10 | if ($INC{'Devel/Cover.pm'}) { |
11 | print "1..0 # SKIP Devel::Cover does not work with threads yet\n"; |
12 | exit 0; |
13 | } |
a4367b26 |
14 | } |
15 | use threads; |
16 | |
17 | use strict; |
18 | use warnings; |
19 | use Test::More; |
e48635f7 |
20 | use Errno (); |
c5915b45 |
21 | use DBIx::Class::_Util 'sigwarn_silencer'; |
10dd5c05 |
22 | use Time::HiRes qw(time sleep); |
a4367b26 |
23 | |
9dfb034f |
24 | use DBICTest; |
25 | |
a4367b26 |
26 | plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' |
750a4ad2 |
27 | if "$]" < 5.008005; |
a4367b26 |
28 | |
9dfb034f |
29 | plan skip_all => 'Potential problems on Win32 Perl < 5.14 and Variable::Magic - investigation pending' |
750a4ad2 |
30 | if $^O eq 'MSWin32' && "$]" < 5.014 && DBICTest::RunMode->is_plain; |
a4367b26 |
31 | |
10dd5c05 |
32 | # README: If you set the env var to a number greater than 5, |
a4367b26 |
33 | # we will use that many children |
34 | my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; |
10dd5c05 |
35 | if($num_children !~ /^[0-9]+$/ || $num_children < 5) { |
36 | $num_children = 5; |
a4367b26 |
37 | } |
38 | |
39 | my $schema = DBICTest->init_schema(no_deploy => 1); |
40 | isa_ok ($schema, 'DBICTest::Schema'); |
41 | |
10dd5c05 |
42 | # sleep until this spot so everything starts simultaneously |
43 | # add "until turn of second" for prettier display |
44 | my $t = int( time() ) + 4; |
45 | |
a4367b26 |
46 | my @threads; |
c5915b45 |
47 | SKIP: { |
48 | |
49 | local $SIG{__WARN__} = sigwarn_silencer( qr/Thread creation failed/i ); |
50 | |
51 | for (1.. $num_children) { |
52 | push @threads, threads->create(sub { |
10dd5c05 |
53 | my $tid = threads->tid; |
54 | |
55 | sleep ($t - time); |
56 | note ("Thread $tid starting work at " . time() ); |
57 | |
c5915b45 |
58 | my $rsrc = $schema->source('Artist'); |
59 | undef $schema; |
60 | isa_ok ($rsrc->schema, 'DBICTest::Schema'); |
61 | my $s2 = $rsrc->schema->clone; |
62 | |
10dd5c05 |
63 | sleep (0.2); # without this many tasty crashes even on latest perls |
c5915b45 |
64 | }) || do { |
65 | skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 |
66 | if $! == Errno::EAGAIN(); |
67 | |
68 | die "Unable to start thread: $!"; |
69 | }; |
70 | } |
71 | } |
72 | |
a4367b26 |
73 | ok(1, "past spawning"); |
74 | |
75 | $_->join for @threads; |
76 | ok(1, "past joining"); |
77 | |
10dd5c05 |
78 | # Too many threading bugs on exit, none of which have anything to do with |
79 | # the actual stuff we test |
80 | $ENV{DBICTEST_DIRTY_EXIT} = 1 |
81 | if "$]"< 5.012; |
82 | |
a4367b26 |
83 | done_testing; |