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 | |
26 | ### Test the upcoming attributes support |
27 | require DBIx::Class; |
28 | @DBICTest::ATTRTEST::ISA = 'DBIx::Class'; |
29 | |
30 | my $var = \42; |
31 | my $s = quote_sub( |
32 | 'DBICTest::ATTRTEST::attr', |
33 | '$v', |
34 | { '$v' => $var }, |
35 | { |
36 | attributes => [qw( ResultSet )], |
37 | package => 'DBICTest::ATTRTEST', |
38 | }, |
39 | ); |
40 | |
41 | is $s, \&DBICTest::ATTRTEST::attr, 'Same cref installed'; |
42 | |
43 | is DBICTest::ATTRTEST::attr(), 42, 'Sub properly installed and callable'; |
44 | |
45 | is_deeply |
46 | [ attributes::get( $s ) ], |
47 | [ 'ResultSet' ], |
48 | 'Attribute installed', |
49 | unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 |
50 | |
51 | sub add_more_attrs { |
52 | # Test that secondary attribute application works |
53 | attributes->import( |
54 | 'DBICTest::ATTRTEST', |
55 | DBICTest::ATTRTEST->can('attr'), |
56 | 'method', |
57 | 'SomethingNobodyUses', |
58 | ); |
59 | |
60 | # and that double-application also works |
61 | attributes->import( |
62 | 'DBICTest::ATTRTEST', |
63 | DBICTest::ATTRTEST->can('attr'), |
64 | 'SomethingNobodyUses', |
65 | ); |
66 | |
67 | is_deeply |
68 | [ sort( attributes::get( $s ) )], |
69 | [ |
70 | qw( ResultSet SomethingNobodyUses method ), |
71 | |
72 | # before 5.10/5.8.9 internal reserved would get doubled, sigh |
73 | # |
74 | # FIXME - perhaps need to weed them out somehow at FETCH_CODE_ATTRIBUTES |
75 | # time...? In any case - this is not important at this stage |
76 | ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' ) |
77 | ], |
78 | 'Secondary attributes installed', |
79 | unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 |
80 | |
81 | is_deeply ( |
82 | DBICTest::ATTRTEST->_attr_cache->{$s}, |
83 | [ |
84 | qw( ResultSet SomethingNobodyUses ), |
85 | |
86 | # after 5.10/5.8.9 FETCH_CODE_ATTRIBUTES is never called for reserved |
87 | # attribute names, so there is nothing for DBIC to see |
88 | # |
89 | # FIXME - perhaps need to teach ->_attr to reinvoke attributes::get() ? |
90 | # In any case - this is not important at this stage |
91 | ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' ) |
92 | ], |
93 | 'Attributes visible in DBIC-specific attribute API', |
94 | ); |
95 | } |
96 | |
97 | |
98 | if ($skip_threads) { |
99 | SKIP: { skip "Skipping the thread test: $skip_threads", 1 } |
100 | |
101 | add_more_attrs(); |
102 | } |
103 | else { |
104 | threads->create(sub { |
105 | add_more_attrs(); |
106 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
107 | })->join; |
108 | } |
109 | |
110 | |
111 | done_testing; |