Commit | Line | Data |
c0329273 |
1 | BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } |
2 | |
12e7015a |
3 | # Test is sufficiently involved to *want* to run with "maximum paranoia" |
4 | BEGIN { $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} = 1 } |
5 | |
24fbd7fb |
6 | use warnings; |
7 | use strict; |
8 | |
a4367b26 |
9 | use Config; |
10 | BEGIN { |
24fbd7fb |
11 | my $skipall; |
12 | |
13 | # FIXME: this discrepancy is crazy, need to investigate |
14 | my $mem_needed = ($Config{ptrsize} == 4) |
15 | ? 200 |
16 | : 750 |
17 | ; |
18 | |
19 | if( ! $Config{useithreads} ) { |
20 | $skipall = 'your perl does not support ithreads'; |
21 | } |
22 | elsif( "$]" < 5.008005 ) { |
23 | $skipall = 'DBIC does not actively support threads before perl 5.8.5'; |
24 | } |
25 | elsif( $INC{'Devel/Cover.pm'} ) { |
26 | $skipall = 'Devel::Cover does not work with ithreads yet'; |
27 | } |
28 | elsif( |
29 | ! $ENV{DBICTEST_RUN_ALL_TESTS} |
30 | and |
31 | require DBICTest::RunMode |
32 | and |
33 | ! DBICTest::RunMode->is_smoker |
34 | ) { |
35 | $skipall = "Test is too expensive (may use up to ${mem_needed}MB of memory), skipping on non-smoker"; |
a4367b26 |
36 | } |
24fbd7fb |
37 | else { |
38 | require threads; |
39 | threads->import(); |
f15baf68 |
40 | |
24fbd7fb |
41 | require DBICTest; |
42 | # without this the can_alloc may very well shoot half of the CI down |
43 | DBICTest->import(':GlobalLock'); |
44 | |
45 | unless ( DBICTest::Util::can_alloc_MB($mem_needed) ) { |
46 | $skipall = "Your system does not have the necessary amount of memory (${mem_needed}MB) for this ridiculous test"; |
47 | } |
48 | } |
49 | |
50 | if( $skipall ) { |
51 | print "1..0 # SKIP $skipall\n"; |
f15baf68 |
52 | exit 0; |
53 | } |
a4367b26 |
54 | } |
a4367b26 |
55 | |
a4367b26 |
56 | use Test::More; |
e48635f7 |
57 | use Errno (); |
c5915b45 |
58 | use DBIx::Class::_Util 'sigwarn_silencer'; |
10dd5c05 |
59 | use Time::HiRes qw(time sleep); |
ef25a429 |
60 | use List::Util 'max'; |
a4367b26 |
61 | |
10dd5c05 |
62 | # README: If you set the env var to a number greater than 5, |
a4367b26 |
63 | # we will use that many children |
64 | my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; |
10dd5c05 |
65 | if($num_children !~ /^[0-9]+$/ || $num_children < 5) { |
66 | $num_children = 5; |
a4367b26 |
67 | } |
68 | |
69 | my $schema = DBICTest->init_schema(no_deploy => 1); |
70 | isa_ok ($schema, 'DBICTest::Schema'); |
71 | |
10dd5c05 |
72 | # sleep until this spot so everything starts simultaneously |
73 | # add "until turn of second" for prettier display |
74 | my $t = int( time() ) + 4; |
75 | |
a4367b26 |
76 | my @threads; |
c5915b45 |
77 | SKIP: { |
78 | |
79 | local $SIG{__WARN__} = sigwarn_silencer( qr/Thread creation failed/i ); |
80 | |
81 | for (1.. $num_children) { |
82 | push @threads, threads->create(sub { |
10dd5c05 |
83 | my $tid = threads->tid; |
84 | |
ef25a429 |
85 | sleep( max( 0.1, $t - time ) ); |
10dd5c05 |
86 | note ("Thread $tid starting work at " . time() ); |
87 | |
c5915b45 |
88 | my $rsrc = $schema->source('Artist'); |
89 | undef $schema; |
90 | isa_ok ($rsrc->schema, 'DBICTest::Schema'); |
91 | my $s2 = $rsrc->schema->clone; |
92 | |
10dd5c05 |
93 | sleep (0.2); # without this many tasty crashes even on latest perls |
c5915b45 |
94 | }) || do { |
95 | skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 |
96 | if $! == Errno::EAGAIN(); |
97 | |
98 | die "Unable to start thread: $!"; |
99 | }; |
100 | } |
101 | } |
102 | |
a4367b26 |
103 | ok(1, "past spawning"); |
104 | |
105 | $_->join for @threads; |
24fbd7fb |
106 | |
a4367b26 |
107 | ok(1, "past joining"); |
108 | |
10dd5c05 |
109 | # Too many threading bugs on exit, none of which have anything to do with |
110 | # the actual stuff we test |
111 | $ENV{DBICTEST_DIRTY_EXIT} = 1 |
112 | if "$]"< 5.012; |
113 | |
a4367b26 |
114 | done_testing; |