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 { package UEBERVERSAL; sub ueber {} }
36 @UNIVERSAL::ISA = "UEBERVERSAL";
38 sub grab_pkg_gen ($) {
39 push @{ $pkg_gen_history->{$_[0]} }, [
40 DBIx::Class::_Util::get_real_pkg_gen($_[0]),
41 'line ' . ( (caller(0))[2] ),
45 @DBICTest::AttrLegacy::ISA = 'DBIx::Class';
46 sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 }
48 grab_pkg_gen("DBICTest::AttrLegacy");
52 'DBICTest::AttrLegacy::attr',
56 attributes => [qw( ResultSet DBIC_random_attr )],
57 package => 'DBICTest::AttrLegacy',
61 grab_pkg_gen("DBICTest::AttrLegacy");
63 is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed';
65 is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable';
68 [ sort( attributes::get( $s ) ) ],
69 [qw( DBIC_random_attr ResultSet )],
70 'Attribute installed',
74 package DBICTest::SomeGrandParentClass;
75 use base 'DBIx::Class::MethodAttributes';
76 sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) };
79 package DBICTest::SomeParentClass;
80 use base qw(DBICTest::SomeGrandParentClass);
83 package DBICTest::AnotherParentClass;
84 use base 'DBIx::Class::MethodAttributes';
85 sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ };
89 package DBICTest::AttrTest;
91 @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass );
94 ::grab_pkg_gen("DBICTest::AttrTest");
96 eval <<'EOS' or die $@;
97 sub attr :lvalue :method :DBIC_attr1 { $$var}
101 ::grab_pkg_gen("DBICTest::AttrTest");
105 'DBICTest::AttrTest',
106 DBICTest::AttrTest->can('attr'),
109 } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/;
113 [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
114 [qw( DBIC_attr1 lvalue method )],
115 'Attribute installed',
119 ! DBICTest::AttrTest->can('__attr_cache'),
120 'Inherited classdata never created on core attrs'
124 DBICTest::AttrTest->_attr_cache,
126 'Cache never instantiated on core attrs'
131 # Test that secondary attribute application works
133 'DBICTest::AttrLegacy',
134 DBICTest::AttrLegacy->can('attr'),
135 'SomethingNobodyUses',
138 # and that double-application also works
140 'DBICTest::AttrLegacy',
141 DBICTest::AttrLegacy->can('attr'),
142 'SomethingNobodyUses',
145 grab_pkg_gen("DBICTest::AttrLegacy");
148 [ sort( attributes::get( $s ) )],
149 [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ],
150 'Secondary attributes installed',
154 DBICTest::AttrLegacy->_attr_cache->{$s},
155 [ qw( ResultSet SomethingNobodyUses ) ],
156 'Attributes visible in legacy DBIC attribute API',
159 # Test that secondary attribute application works
161 'DBICTest::AttrTest',
162 DBICTest::AttrTest->can('attr'),
166 grab_pkg_gen("DBICTest::AttrTest");
168 # and that double-application also works
170 'DBICTest::AttrTest',
171 DBICTest::AttrTest->can('attr'),
176 grab_pkg_gen("DBICTest::AttrTest");
179 [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ],
180 [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )],
181 'DBIC-specific attribute installed',
185 ! DBICTest::AttrTest->can('__attr_cache'),
186 'Inherited classdata never created on core+DBIC-specific attrs'
190 DBICTest::AttrTest->_attr_cache,
192 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs'
195 # no point dragging in threads::shared, just do the check here
196 for my $class ( keys %$pkg_gen_history ) {
197 my $stack = $pkg_gen_history->{$class};
199 for my $i ( 1 .. $#$stack ) {
202 ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ),
204 "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]"
210 # check that class description is stable, and changes when needed
217 my $desc = describe_class_methods($class);
220 describe_class_methods($class),
222 "describe_class_methods result is stable over '$class' (pass $_)"
231 eval "sub UEBERVERSAL::some_unimethod_$cnt {}; 1" or die $@;
233 my $rv = describe_class_methods($class);
235 delete ${"UEBERVERSAL::"}{"some_unimethod_$cnt"};
240 delete $_->{cumulative_gen} for $desc, $desc2;
245 "touching UNIVERSAL changed '$class' method availability"
249 my $bottom_most_V_D_C_A = refdesc(
250 describe_class_methods("DBIx::Class::MethodAttributes")
252 ->{VALID_DBIC_CODE_ATTRIBUTE}
256 for my $class ( shuffle( qw(
259 DBICTest::SomeGrandParentClass
261 DBIx::Class::ResultSet
262 DBICTest::Schema::Track
264 my $desc = describe_class_methods($class);
267 refdesc( $desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
268 $bottom_most_V_D_C_A,
269 "Same physical structure returned for last VALID_DBIC_CODE_ATTRIBUTE via class $class"
273 refdesc( $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ),
274 $bottom_most_V_D_C_A,
275 "Same physical structure returned for bottom-most SUPER of VALID_DBIC_CODE_ATTRIBUTE via class $class"
276 ) if $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE};
279 # check that describe_class_methods returns the right stuff
280 # ( on the simpler class )
281 my $expected_AttrTest_ISA = [qw(
282 DBICTest::SomeParentClass
283 DBICTest::SomeGrandParentClass
284 DBICTest::AnotherParentClass
285 DBIx::Class::MethodAttributes
288 my $expected_desc = {
289 class => "DBICTest::AttrTest",
291 # sum and/or is_deeply are buggy on old List::Util/Test::More
292 # do the sum by hand ourselves to be sure
293 cumulative_gen => do {
294 require Math::BigInt;
295 my $gen = Math::BigInt->new(0);
297 $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for (
300 'DBICTest::AttrTest',
301 @$expected_AttrTest_ISA,
310 isa => $expected_AttrTest_ISA,
312 FETCH_CODE_ATTRIBUTES => [
315 name => "FETCH_CODE_ATTRIBUTES",
316 via_class => "DBIx::Class::MethodAttributes"
319 MODIFY_CODE_ATTRIBUTES => [
322 name => "MODIFY_CODE_ATTRIBUTES",
323 via_class => "DBIx::Class::MethodAttributes"
326 VALID_DBIC_CODE_ATTRIBUTE => [
329 name => "VALID_DBIC_CODE_ATTRIBUTE",
330 via_class => "DBICTest::SomeGrandParentClass",
334 name => "VALID_DBIC_CODE_ATTRIBUTE",
335 via_class => "DBICTest::AnotherParentClass"
339 name => "VALID_DBIC_CODE_ATTRIBUTE",
340 via_class => "DBIx::Class::MethodAttributes"
346 name => "_attr_cache",
347 via_class => "DBIx::Class::MethodAttributes"
360 via_class => "DBICTest::AttrTest"
367 via_class => "UEBERVERSAL",
374 via_class => "UNIVERSAL",
381 via_class => "UNIVERSAL",
388 via_class => "UNIVERSAL",
391 ( DBIx::Class::_ENV_::OLD_MRO ? () : (
395 via_class => "UNIVERSAL",
401 $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}
402 = $expected_desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE};
404 $expected_desc->{methods_defined_in_class}{attr}
405 = $expected_desc->{methods}{attr}[0];
408 describe_class_methods("DBICTest::AttrTest"),
410 'describe_class_methods returns correct data',
415 SKIP: { skip "Skipping the thread test: $skip_threads", 1 }
421 my $t = threads->create(sub {
423 my $t = threads->create(sub {
426 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: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 }
441 select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls
445 die "Unable to start thread: $!"
446 unless $! == Errno::EAGAIN();
448 skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1;
454 'Thread stack exitted succesfully'
458 # this doesn't really belong in this test, but screw it
460 package DBICTest::WackyDFS;
461 use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass );
465 describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE},
469 name => "VALID_DBIC_CODE_ATTRIBUTE",
470 via_class => "DBICTest::SomeGrandParentClass",
474 name => "VALID_DBIC_CODE_ATTRIBUTE",
475 via_class => "DBIx::Class::MethodAttributes"
478 'Expected description on unusable inheritance hierarchy'