Commit | Line | Data |
a4367b26 |
1 | use Config; |
2 | BEGIN { |
3 | unless ($Config{useithreads}) { |
4 | print "1..0 # SKIP your perl does not support ithreads\n"; |
5 | exit 0; |
6 | } |
7 | } |
8 | use threads; |
9 | |
10 | use strict; |
11 | use warnings; |
12 | use Test::More; |
13 | |
14 | plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' |
15 | if $] < '5.008005'; |
16 | |
50e6c52e |
17 | plan skip_all => 'test dangerous on Win32 for < 5.14 set TEST_AUTHOR to run' |
18 | if $^O eq 'MSWin32' && $] < 5.014 && !$ENV{TEST_AUTHOR}; |
19 | |
a4367b26 |
20 | use lib qw(t/lib); |
21 | use DBICTest; |
22 | |
23 | # README: If you set the env var to a number greater than 10, |
24 | # we will use that many children |
25 | my $num_children = $ENV{DBICTEST_THREAD_STRESS} || 1; |
26 | if($num_children !~ /^[0-9]+$/ || $num_children < 10) { |
27 | $num_children = 10; |
28 | } |
29 | |
30 | my $schema = DBICTest->init_schema(no_deploy => 1); |
31 | isa_ok ($schema, 'DBICTest::Schema'); |
32 | |
33 | my @threads; |
34 | push @threads, threads->create(sub { |
35 | my $rsrc = $schema->source('Artist'); |
36 | undef $schema; |
37 | isa_ok ($rsrc->schema, 'DBICTest::Schema'); |
38 | my $s2 = $rsrc->schema->clone; |
39 | |
40 | sleep 1; # without this many tasty crashes |
41 | }) for (1.. $num_children); |
42 | ok(1, "past spawning"); |
43 | |
44 | $_->join for @threads; |
45 | ok(1, "past joining"); |
46 | |
47 | done_testing; |