1 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
10 if( ! $Config{useithreads} ) {
11 $skip_threads = 'your perl does not support ithreads';
13 elsif( "$]" < 5.008005 ) {
14 $skip_threads = 'DBIC does not actively support threads before perl 5.8.5';
16 elsif( $INC{'Devel/Cover.pm'} ) {
17 $skip_threads = 'Devel::Cover does not work with ithreads yet';
20 unless( $skip_threads ) {
28 use DBIx::Class::_Util qw( quote_sub describe_class_methods serialize refdesc );
29 use List::Util 'shuffle';
34 my $pkg_gen_history = {};
36 { package UEBERVERSAL; sub ueber {} }
37 @UNIVERSAL::ISA = "UEBERVERSAL";
39 sub grab_pkg_gen ($) {
40 push @{ $pkg_gen_history->{$_[0]} }, [
41 DBIx::Class::_Util::get_real_pkg_gen($_[0]),
42 'line ' . ( (caller(0))[2] ),
46 @DBICTest::AttrLegacy::ISA = 'DBIx::Class';
47 sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 }
49 grab_pkg_gen("DBICTest::AttrLegacy");
53 'DBICTest::AttrLegacy::attr',
57 attributes => [qw( ResultSet DBIC_random_attr )],
58 package => 'DBICTest::AttrLegacy',
62 grab_pkg_gen("DBICTest::AttrLegacy");
64 is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed';
66 is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable';
69 [ sort( attributes::get( $s ) ) ],
70 [qw( DBIC_random_attr ResultSet )],
71 'Attribute installed',
75 package DBICTest::SomeGrandParentClass;
76 use base 'DBIx::Class::MethodAttributes';
77 sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) };
80 package DBICTest::SomeParentClass;
81 use base qw(DBICTest::SomeGrandParentClass);
84 package DBICTest::AnotherParentClass;
85 use base 'DBIx::Class::MethodAttributes';
86 sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ };
90 package DBICTest::AttrTest;
92 @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass );
95 # pathological case - but can (and sadly does) happen
96 *VALID_DBIC_CODE_ATTRIBUTE = \&DBICTest::SomeGrandParentClass::VALID_DBIC_CODE_ATTRIBUTE;
98 ::grab_pkg_gen("DBICTest::AttrTest");
100 eval <<'EOS' or die $@;
101 sub attr :lvalue :method :DBIC_attr1 { $$var}
105 ::grab_pkg_gen("DBICTest::AttrTest");
109 'DBICTest::AttrTest',
110 DBICTest::AttrTest->can('attr'),
113 } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/;
117 [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
118 [qw( DBIC_attr1 lvalue method )],
119 'Attribute installed',
123 ! DBICTest::AttrTest->can('__attr_cache'),
124 'Inherited classdata never created on core attrs'
128 DBICTest::AttrTest->_attr_cache,
130 'Cache never instantiated on core attrs'
135 # Test that secondary attribute application works
137 'DBICTest::AttrLegacy',
138 DBICTest::AttrLegacy->can('attr'),
139 'SomethingNobodyUses',
142 # and that double-application also works
144 'DBICTest::AttrLegacy',
145 DBICTest::AttrLegacy->can('attr'),
146 'SomethingNobodyUses',
149 grab_pkg_gen("DBICTest::AttrLegacy");
152 [ sort( attributes::get( $s ) )],
153 [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ],
154 'Secondary attributes installed',
158 DBICTest::AttrLegacy->_attr_cache->{$s},
159 [ qw( ResultSet SomethingNobodyUses ) ],
160 'Attributes visible in legacy DBIC attribute API',
163 # Test that secondary attribute application works
165 'DBICTest::AttrTest',
166 DBICTest::AttrTest->can('attr'),
170 grab_pkg_gen("DBICTest::AttrTest");
172 # and that double-application also works
174 'DBICTest::AttrTest',
175 DBICTest::AttrTest->can('attr'),
180 grab_pkg_gen("DBICTest::AttrTest");
183 [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
184 [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )],
185 'DBIC-specific attribute installed',
189 ! DBICTest::AttrTest->can('__attr_cache'),
190 'Inherited classdata never created on core+DBIC-specific attrs'
194 DBICTest::AttrTest->_attr_cache,
196 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs'
199 # no point dragging in threads::shared, just do the check here
200 for my $class ( keys %$pkg_gen_history ) {
201 my $stack = $pkg_gen_history->{$class};
203 for my $i ( 1 .. $#$stack ) {
206 ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ),
208 "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]"
214 # check that class description is stable, and changes when needed
216 # FIXME - this list used to contain 'main', but that started failing as
217 # of the commit introducing this line with bizarre "unstable gen" errors
218 # Punting for the time being - will fix at some point in the future
225 my $desc = describe_class_methods($class);
228 describe_class_methods($class),
230 "describe_class_methods result is stable over '$class' (pass $_)"
238 eval "sub UEBERVERSAL::some_unimethod_$cnt {}; 1" or die $@;
240 my $rv = describe_class_methods($class);
242 delete ${"UEBERVERSAL::"}{"some_unimethod_$cnt"};
247 delete $_->{cumulative_gen} for $desc, $desc2;
252 "touching UNIVERSAL changed '$class' method availability"
256 my $bottom_most_V_D_C_A = refdesc(
257 describe_class_methods("DBIx::Class::MethodAttributes")
259 ->{VALID_DBIC_CODE_ATTRIBUTE}
263 for my $class ( shuffle( qw(
266 DBICTest::SomeGrandParentClass
268 DBIx::Class::ResultSet
269 DBICTest::Schema::Track
271 my $desc = describe_class_methods($class);
274 refdesc( $desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
275 $bottom_most_V_D_C_A,
276 "Same physical structure returned for last VALID_DBIC_CODE_ATTRIBUTE via class $class"
280 refdesc( $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
281 $bottom_most_V_D_C_A,
282 "Same physical structure returned for bottom-most SUPER of VALID_DBIC_CODE_ATTRIBUTE via class $class"
283 ) if $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE};
286 # check that describe_class_methods returns the right stuff
287 # ( on the simpler class )
288 my $expected_AttrTest_ISA = [qw(
289 DBICTest::SomeParentClass
290 DBICTest::SomeGrandParentClass
291 DBICTest::AnotherParentClass
292 DBIx::Class::MethodAttributes
295 my $expected_desc = {
296 class => "DBICTest::AttrTest",
298 # sum and/or is_deeply are buggy on old List::Util/Test::More
299 # do the sum by hand ourselves to be sure
300 cumulative_gen => do {
301 require Math::BigInt;
302 my $gen = Math::BigInt->new(0);
304 $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for (
307 'DBICTest::AttrTest',
308 @$expected_AttrTest_ISA,
317 isa => $expected_AttrTest_ISA,
319 FETCH_CODE_ATTRIBUTES => [
322 name => "FETCH_CODE_ATTRIBUTES",
323 via_class => "DBIx::Class::MethodAttributes"
326 MODIFY_CODE_ATTRIBUTES => [
329 name => "MODIFY_CODE_ATTRIBUTES",
330 via_class => "DBIx::Class::MethodAttributes"
333 VALID_DBIC_CODE_ATTRIBUTE => ( my $V_D_C_A_stack = [
336 name => 'VALID_DBIC_CODE_ATTRIBUTE',
337 via_class => 'DBICTest::AttrTest'
341 name => "VALID_DBIC_CODE_ATTRIBUTE",
342 via_class => "DBICTest::SomeGrandParentClass",
346 name => "VALID_DBIC_CODE_ATTRIBUTE",
347 via_class => "DBICTest::AnotherParentClass"
351 name => "VALID_DBIC_CODE_ATTRIBUTE",
352 via_class => "DBIx::Class::MethodAttributes"
358 name => "_attr_cache",
359 via_class => "DBIx::Class::MethodAttributes"
372 via_class => "DBICTest::AttrTest"
379 via_class => "UEBERVERSAL",
386 via_class => "UNIVERSAL",
393 via_class => "UNIVERSAL",
400 via_class => "UNIVERSAL",
403 ( DBIx::Class::_ENV_::OLD_MRO ? () : (
407 via_class => "UNIVERSAL",
413 $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}
416 $expected_desc->{methods_defined_in_class}{VALID_DBIC_CODE_ATTRIBUTE}
417 = $V_D_C_A_stack->[0];
419 $expected_desc->{methods_defined_in_class}{attr}
420 = $expected_desc->{methods}{attr}[0];
423 describe_class_methods("DBICTest::AttrTest"),
425 'describe_class_methods returns correct data',
430 SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
436 my $t = threads->create(sub {
438 my $t = threads->create(sub {
441 select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
446 die "Unable to start thread: $!"
447 unless $! == Errno::EAGAIN();
449 SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 }
456 select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
460 die "Unable to start thread: $!"
461 unless $! == Errno::EAGAIN();
463 skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1;
469 'Thread stack exitted succesfully'
473 # this doesn't really belong in this test, but screw it
475 package DBICTest::WackyDFS;
476 use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass );
480 describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE},
484 name => "VALID_DBIC_CODE_ATTRIBUTE",
485 via_class => "DBICTest::SomeGrandParentClass",
489 name => "VALID_DBIC_CODE_ATTRIBUTE",
490 via_class => "DBIx::Class::MethodAttributes"
493 'Expected description on unusable inheritance hierarchy'