7 if( ! $Config{useithreads} ) {
8 $skip_threads = 'your perl does not support ithreads';
10 elsif( "$]" < 5.008005 ) {
11 $skip_threads = 'DBIC does not actively support threads before perl 5.8.5';
13 elsif( $INC{'Devel/Cover.pm'} ) {
14 $skip_threads = 'Devel::Cover does not work with ithreads yet';
17 unless( $skip_threads ) {
25 use DBIx::Class::_Util qw( quote_sub );
28 @DBICTest::AttrLegacy::ISA = 'DBIx::Class';
29 sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 }
33 'DBICTest::AttrLegacy::attr',
37 attributes => [qw( ResultSet DBIC_random_attr )],
38 package => 'DBICTest::AttrLegacy',
42 is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed';
44 is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable';
47 [ sort( attributes::get( $s ) ) ],
48 [qw( DBIC_random_attr ResultSet )],
49 'Attribute installed',
50 unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
53 @DBICTest::AttrTest::ISA = 'DBIx::Class';
55 package DBICTest::AttrTest;
57 eval <<'EOS' or die $@;
58 sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ }
59 sub attr :lvalue :method :DBIC_attr1 { $$var}
66 DBICTest::AttrTest->can('attr'),
69 } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/;
73 [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
74 [qw( DBIC_attr1 lvalue method )],
75 'Attribute installed',
76 unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
79 ! DBICTest::AttrTest->can('__attr_cache'),
80 'Inherited classdata never created on core attrs'
84 DBICTest::AttrTest->_attr_cache,
86 'Cache never instantiated on core attrs'
90 # Test that secondary attribute application works
92 'DBICTest::AttrLegacy',
93 DBICTest::AttrLegacy->can('attr'),
94 'SomethingNobodyUses',
97 # and that double-application also works
99 'DBICTest::AttrLegacy',
100 DBICTest::AttrLegacy->can('attr'),
101 'SomethingNobodyUses',
105 [ sort( attributes::get( $s ) )],
106 [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ],
107 'Secondary attributes installed',
108 unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
111 DBICTest::AttrLegacy->_attr_cache->{$s},
112 [ qw( ResultSet SomethingNobodyUses ) ],
113 'Attributes visible in legacy DBIC attribute API',
118 # Test that secondary attribute application works
120 'DBICTest::AttrTest',
121 DBICTest::AttrTest->can('attr'),
125 # and that double-application also works
127 'DBICTest::AttrTest',
128 DBICTest::AttrTest->can('attr'),
134 [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
135 [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )],
136 'DBIC-specific attribute installed',
137 unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147
140 ! DBICTest::AttrTest->can('__attr_cache'),
141 'Inherited classdata never created on core+DBIC-specific attrs'
145 DBICTest::AttrTest->_attr_cache,
147 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs'
153 SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
158 threads->create(sub {
160 threads->create(sub {
163 select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
167 select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls