Commit | Line | Data |
7bd921c0 |
1 | use warnings; |
2 | use strict; |
3 | |
4 | use Config; |
5 | my $skip_threads; |
6 | BEGIN { |
7 | if( ! $Config{useithreads} ) { |
8 | $skip_threads = 'your perl does not support ithreads'; |
9 | } |
10 | elsif( "$]" < 5.008005 ) { |
11 | $skip_threads = 'DBIC does not actively support threads before perl 5.8.5'; |
12 | } |
13 | elsif( $INC{'Devel/Cover.pm'} ) { |
14 | $skip_threads = 'Devel::Cover does not work with ithreads yet'; |
15 | } |
16 | |
17 | unless( $skip_threads ) { |
18 | require threads; |
19 | threads->import; |
20 | } |
21 | } |
22 | |
23 | use Test::More; |
24 | use DBIx::Class::_Util qw( quote_sub modver_gt_or_eq ); |
25 | |
7bd921c0 |
26 | require DBIx::Class; |
27 | @DBICTest::ATTRTEST::ISA = 'DBIx::Class'; |
28 | |
29 | my $var = \42; |
30 | my $s = quote_sub( |
31 | 'DBICTest::ATTRTEST::attr', |
32 | '$v', |
33 | { '$v' => $var }, |
34 | { |
35 | attributes => [qw( ResultSet )], |
36 | package => 'DBICTest::ATTRTEST', |
37 | }, |
38 | ); |
39 | |
40 | is $s, \&DBICTest::ATTRTEST::attr, 'Same cref installed'; |
41 | |
42 | is DBICTest::ATTRTEST::attr(), 42, 'Sub properly installed and callable'; |
43 | |
44 | is_deeply |
45 | [ attributes::get( $s ) ], |
46 | [ 'ResultSet' ], |
47 | 'Attribute installed', |
48 | unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 |
49 | |
50 | sub add_more_attrs { |
51 | # Test that secondary attribute application works |
52 | attributes->import( |
53 | 'DBICTest::ATTRTEST', |
54 | DBICTest::ATTRTEST->can('attr'), |
55 | 'method', |
56 | 'SomethingNobodyUses', |
57 | ); |
58 | |
59 | # and that double-application also works |
60 | attributes->import( |
61 | 'DBICTest::ATTRTEST', |
62 | DBICTest::ATTRTEST->can('attr'), |
63 | 'SomethingNobodyUses', |
64 | ); |
65 | |
66 | is_deeply |
67 | [ sort( attributes::get( $s ) )], |
68 | [ |
69 | qw( ResultSet SomethingNobodyUses method ), |
70 | |
71 | # before 5.10/5.8.9 internal reserved would get doubled, sigh |
72 | # |
73 | # FIXME - perhaps need to weed them out somehow at FETCH_CODE_ATTRIBUTES |
74 | # time...? In any case - this is not important at this stage |
75 | ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' ) |
76 | ], |
77 | 'Secondary attributes installed', |
78 | unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 |
79 | |
80 | is_deeply ( |
81 | DBICTest::ATTRTEST->_attr_cache->{$s}, |
82 | [ |
83 | qw( ResultSet SomethingNobodyUses ), |
84 | |
85 | # after 5.10/5.8.9 FETCH_CODE_ATTRIBUTES is never called for reserved |
86 | # attribute names, so there is nothing for DBIC to see |
87 | # |
88 | # FIXME - perhaps need to teach ->_attr to reinvoke attributes::get() ? |
89 | # In any case - this is not important at this stage |
90 | ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' ) |
91 | ], |
92 | 'Attributes visible in DBIC-specific attribute API', |
93 | ); |
94 | } |
95 | |
96 | |
97 | if ($skip_threads) { |
98 | SKIP: { skip "Skipping the thread test: $skip_threads", 1 } |
99 | |
100 | add_more_attrs(); |
101 | } |
102 | else { |
103 | threads->create(sub { |
0130575a |
104 | |
105 | threads->create(sub { |
106 | |
107 | add_more_attrs(); |
108 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
109 | |
110 | })->join; |
111 | |
7bd921c0 |
112 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
0130575a |
113 | |
7bd921c0 |
114 | })->join; |
115 | } |
116 | |
7bd921c0 |
117 | done_testing; |