1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
9 if( ! $Config{useithreads} ) {
10 $skip_threads = 'your perl does not support ithreads';
12 elsif( "$]" < 5.008005 ) {
13 $skip_threads = 'DBIC does not actively support threads before perl 5.8.5';
15 elsif( $INC{'Devel/Cover.pm'} ) {
16 $skip_threads = 'Devel::Cover does not work with ithreads yet';
19 unless( $skip_threads ) {
27 use DBIx::Class::_Util qw( quote_sub describe_class_methods serialize refdesc );
28 use List::Util 'shuffle';
33 my $pkg_gen_history = {};
35 sub grab_pkg_gen ($) {
36 push @{ $pkg_gen_history->{$_[0]} }, [
37 DBIx::Class::_Util::get_real_pkg_gen($_[0]),
38 'line ' . ( (caller(0))[2] ),
42 @DBICTest::AttrLegacy::ISA = 'DBIx::Class';
43 sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 }
45 grab_pkg_gen("DBICTest::AttrLegacy");
49 'DBICTest::AttrLegacy::attr',
53 attributes => [qw( ResultSet DBIC_random_attr )],
54 package => 'DBICTest::AttrLegacy',
58 grab_pkg_gen("DBICTest::AttrLegacy");
60 is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed';
62 is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable';
65 [ sort( attributes::get( $s ) ) ],
66 [qw( DBIC_random_attr ResultSet )],
67 'Attribute installed',
71 package DBICTest::SomeGrandParentClass;
72 use base 'DBIx::Class::MethodAttributes';
73 sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) };
76 package DBICTest::SomeParentClass;
77 use base qw(DBICTest::SomeGrandParentClass);
80 package DBICTest::AnotherParentClass;
81 use base 'DBIx::Class::MethodAttributes';
82 sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ };
86 package DBICTest::AttrTest;
88 @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass );
91 ::grab_pkg_gen("DBICTest::AttrTest");
93 eval <<'EOS' or die $@;
94 sub attr :lvalue :method :DBIC_attr1 { $$var}
98 ::grab_pkg_gen("DBICTest::AttrTest");
102 'DBICTest::AttrTest',
103 DBICTest::AttrTest->can('attr'),
106 } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/;
110 [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
111 [qw( DBIC_attr1 lvalue method )],
112 'Attribute installed',
116 ! DBICTest::AttrTest->can('__attr_cache'),
117 'Inherited classdata never created on core attrs'
121 DBICTest::AttrTest->_attr_cache,
123 'Cache never instantiated on core attrs'
128 # Test that secondary attribute application works
130 'DBICTest::AttrLegacy',
131 DBICTest::AttrLegacy->can('attr'),
132 'SomethingNobodyUses',
135 # and that double-application also works
137 'DBICTest::AttrLegacy',
138 DBICTest::AttrLegacy->can('attr'),
139 'SomethingNobodyUses',
142 grab_pkg_gen("DBICTest::AttrLegacy");
145 [ sort( attributes::get( $s ) )],
146 [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ],
147 'Secondary attributes installed',
151 DBICTest::AttrLegacy->_attr_cache->{$s},
152 [ qw( ResultSet SomethingNobodyUses ) ],
153 'Attributes visible in legacy DBIC attribute API',
156 # Test that secondary attribute application works
158 'DBICTest::AttrTest',
159 DBICTest::AttrTest->can('attr'),
163 grab_pkg_gen("DBICTest::AttrTest");
165 # and that double-application also works
167 'DBICTest::AttrTest',
168 DBICTest::AttrTest->can('attr'),
173 grab_pkg_gen("DBICTest::AttrTest");
176 [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
177 [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )],
178 'DBIC-specific attribute installed',
182 ! DBICTest::AttrTest->can('__attr_cache'),
183 'Inherited classdata never created on core+DBIC-specific attrs'
187 DBICTest::AttrTest->_attr_cache,
189 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs'
192 # no point dragging in threads::shared, just do the check here
193 for my $class ( keys %$pkg_gen_history ) {
194 my $stack = $pkg_gen_history->{$class};
196 for my $i ( 1 .. $#$stack ) {
199 ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ),
201 "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]"
207 # check that class description is stable, and changes when needed
214 my $desc = describe_class_methods($class);
217 describe_class_methods($class),
219 "describe_class_methods result is stable over '$class' (pass $_)"
228 eval "sub UNIVERSAL::some_unimethod_$cnt {}; 1" or die $@;
230 my $rv = describe_class_methods($class);
232 delete ${"UNIVERSAL::"}{"some_unimethod_$cnt"};
237 delete $_->{cumulative_gen} for $desc, $desc2;
242 "touching UNIVERSAL changed '$class' method availability"
246 my $bottom_most_V_D_C_A = refdesc(
247 describe_class_methods("DBIx::Class::MethodAttributes")
249 ->{VALID_DBIC_CODE_ATTRIBUTE}
253 for my $class ( shuffle( qw(
256 DBICTest::SomeGrandParentClass
258 DBIx::Class::ResultSet
259 DBICTest::Schema::Track
261 my $desc = describe_class_methods($class);
264 refdesc( $desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
265 $bottom_most_V_D_C_A,
266 "Same physical structure returned for last VALID_DBIC_CODE_ATTRIBUTE via class $class"
270 refdesc( $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
271 $bottom_most_V_D_C_A,
272 "Same physical structure returned for bottom-most SUPER of VALID_DBIC_CODE_ATTRIBUTE via class $class"
273 ) if $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE};
276 # check that describe_class_methods returns the right stuff
277 # ( on the simpler class )
278 my $expected_AttrTest_ISA = [qw(
279 DBICTest::SomeParentClass
280 DBICTest::SomeGrandParentClass
281 DBICTest::AnotherParentClass
282 DBIx::Class::MethodAttributes
285 my $expected_desc = {
286 class => "DBICTest::AttrTest",
288 # sum and/or is_deeply are buggy on old List::Util/Test::More
289 # do the sum by hand ourselves to be sure
290 cumulative_gen => do {
291 require Math::BigInt;
292 my $gen = Math::BigInt->new(0);
294 $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for (
296 'DBICTest::AttrTest',
297 @$expected_AttrTest_ISA,
306 isa => $expected_AttrTest_ISA,
308 FETCH_CODE_ATTRIBUTES => [
311 name => "FETCH_CODE_ATTRIBUTES",
312 via_class => "DBIx::Class::MethodAttributes"
315 MODIFY_CODE_ATTRIBUTES => [
318 name => "MODIFY_CODE_ATTRIBUTES",
319 via_class => "DBIx::Class::MethodAttributes"
322 VALID_DBIC_CODE_ATTRIBUTE => [
325 name => "VALID_DBIC_CODE_ATTRIBUTE",
326 via_class => "DBICTest::SomeGrandParentClass",
330 name => "VALID_DBIC_CODE_ATTRIBUTE",
331 via_class => "DBICTest::AnotherParentClass"
335 name => "VALID_DBIC_CODE_ATTRIBUTE",
336 via_class => "DBIx::Class::MethodAttributes"
342 name => "_attr_cache",
343 via_class => "DBIx::Class::MethodAttributes"
356 via_class => "DBICTest::AttrTest"
363 via_class => "UNIVERSAL",
370 via_class => "UNIVERSAL",
377 via_class => "UNIVERSAL",
380 ( DBIx::Class::_ENV_::OLD_MRO ? () : (
384 via_class => "UNIVERSAL",
390 $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}
391 = $expected_desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE};
394 describe_class_methods("DBICTest::AttrTest"),
396 'describe_class_methods returns correct data',
401 SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
407 my $t = threads->create(sub {
409 my $t = threads->create(sub {
412 select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
417 die "Unable to start thread: $!"
418 unless $! == Errno::EAGAIN();
420 SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 }
427 select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
431 die "Unable to start thread: $!"
432 unless $! == Errno::EAGAIN();
434 skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1;
440 'Thread stack exitted succesfully'