Commit | Line | Data |
296248c3 |
1 | BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } |
2 | |
7bd921c0 |
3 | use strict; |
1c179556 |
4 | use warnings; |
5 | no warnings 'once'; |
7bd921c0 |
6 | |
7 | use Config; |
8 | my $skip_threads; |
9 | BEGIN { |
10 | if( ! $Config{useithreads} ) { |
11 | $skip_threads = 'your perl does not support ithreads'; |
12 | } |
13 | elsif( "$]" < 5.008005 ) { |
14 | $skip_threads = 'DBIC does not actively support threads before perl 5.8.5'; |
15 | } |
16 | elsif( $INC{'Devel/Cover.pm'} ) { |
17 | $skip_threads = 'Devel::Cover does not work with ithreads yet'; |
18 | } |
19 | |
20 | unless( $skip_threads ) { |
21 | require threads; |
22 | threads->import; |
23 | } |
24 | } |
25 | |
26 | use Test::More; |
5ab72593 |
27 | use Test::Exception; |
296248c3 |
28 | use DBIx::Class::_Util qw( quote_sub describe_class_methods serialize refdesc ); |
29 | use List::Util 'shuffle'; |
30 | use Errno (); |
31 | |
32 | use DBICTest; |
33 | |
34 | my $pkg_gen_history = {}; |
35 | |
d01688cc |
36 | { package UEBERVERSAL; sub ueber {} } |
37 | @UNIVERSAL::ISA = "UEBERVERSAL"; |
38 | |
296248c3 |
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] ), |
43 | ]; |
44 | } |
7bd921c0 |
45 | |
5ab72593 |
46 | @DBICTest::AttrLegacy::ISA = 'DBIx::Class'; |
47 | sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 } |
7bd921c0 |
48 | |
296248c3 |
49 | grab_pkg_gen("DBICTest::AttrLegacy"); |
50 | |
7bd921c0 |
51 | my $var = \42; |
52 | my $s = quote_sub( |
5ab72593 |
53 | 'DBICTest::AttrLegacy::attr', |
7bd921c0 |
54 | '$v', |
55 | { '$v' => $var }, |
56 | { |
5ab72593 |
57 | attributes => [qw( ResultSet DBIC_random_attr )], |
58 | package => 'DBICTest::AttrLegacy', |
7bd921c0 |
59 | }, |
60 | ); |
61 | |
296248c3 |
62 | grab_pkg_gen("DBICTest::AttrLegacy"); |
63 | |
5ab72593 |
64 | is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed'; |
7bd921c0 |
65 | |
5ab72593 |
66 | is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable'; |
7bd921c0 |
67 | |
68 | is_deeply |
5ab72593 |
69 | [ sort( attributes::get( $s ) ) ], |
70 | [qw( DBIC_random_attr ResultSet )], |
7bd921c0 |
71 | 'Attribute installed', |
296248c3 |
72 | ; |
7bd921c0 |
73 | |
296248c3 |
74 | { |
75 | package DBICTest::SomeGrandParentClass; |
76 | use base 'DBIx::Class::MethodAttributes'; |
77 | sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) }; |
78 | } |
79 | { |
80 | package DBICTest::SomeParentClass; |
81 | use base qw(DBICTest::SomeGrandParentClass); |
82 | } |
83 | { |
84 | package DBICTest::AnotherParentClass; |
85 | use base 'DBIx::Class::MethodAttributes'; |
86 | sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ }; |
87 | } |
5ab72593 |
88 | |
5ab72593 |
89 | { |
296248c3 |
90 | package DBICTest::AttrTest; |
91 | |
92 | @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass ); |
93 | use mro 'c3'; |
94 | |
1c179556 |
95 | # pathological case - but can (and sadly does) happen |
96 | *VALID_DBIC_CODE_ATTRIBUTE = \&DBICTest::SomeGrandParentClass::VALID_DBIC_CODE_ATTRIBUTE; |
97 | |
296248c3 |
98 | ::grab_pkg_gen("DBICTest::AttrTest"); |
5ab72593 |
99 | |
296248c3 |
100 | eval <<'EOS' or die $@; |
5ab72593 |
101 | sub attr :lvalue :method :DBIC_attr1 { $$var} |
102 | 1; |
103 | EOS |
104 | |
296248c3 |
105 | ::grab_pkg_gen("DBICTest::AttrTest"); |
106 | |
107 | ::throws_ok { |
108 | attributes->import( |
109 | 'DBICTest::AttrTest', |
110 | DBICTest::AttrTest->can('attr'), |
111 | 'DBIC_unknownattr', |
112 | ); |
113 | } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/; |
5ab72593 |
114 | } |
115 | |
116 | is_deeply |
117 | [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], |
118 | [qw( DBIC_attr1 lvalue method )], |
119 | 'Attribute installed', |
296248c3 |
120 | ; |
5ab72593 |
121 | |
122 | ok( |
123 | ! DBICTest::AttrTest->can('__attr_cache'), |
124 | 'Inherited classdata never created on core attrs' |
125 | ); |
126 | |
127 | is_deeply( |
128 | DBICTest::AttrTest->_attr_cache, |
129 | {}, |
130 | 'Cache never instantiated on core attrs' |
131 | ); |
132 | |
7bd921c0 |
133 | sub add_more_attrs { |
296248c3 |
134 | |
7bd921c0 |
135 | # Test that secondary attribute application works |
136 | attributes->import( |
5ab72593 |
137 | 'DBICTest::AttrLegacy', |
138 | DBICTest::AttrLegacy->can('attr'), |
7bd921c0 |
139 | 'SomethingNobodyUses', |
140 | ); |
141 | |
142 | # and that double-application also works |
143 | attributes->import( |
5ab72593 |
144 | 'DBICTest::AttrLegacy', |
145 | DBICTest::AttrLegacy->can('attr'), |
7bd921c0 |
146 | 'SomethingNobodyUses', |
147 | ); |
148 | |
296248c3 |
149 | grab_pkg_gen("DBICTest::AttrLegacy"); |
150 | |
7bd921c0 |
151 | is_deeply |
152 | [ sort( attributes::get( $s ) )], |
5ab72593 |
153 | [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ], |
7bd921c0 |
154 | 'Secondary attributes installed', |
296248c3 |
155 | ; |
7bd921c0 |
156 | |
157 | is_deeply ( |
5ab72593 |
158 | DBICTest::AttrLegacy->_attr_cache->{$s}, |
159 | [ qw( ResultSet SomethingNobodyUses ) ], |
160 | 'Attributes visible in legacy DBIC attribute API', |
161 | ); |
162 | |
5ab72593 |
163 | # Test that secondary attribute application works |
164 | attributes->import( |
165 | 'DBICTest::AttrTest', |
166 | DBICTest::AttrTest->can('attr'), |
167 | 'DBIC_attr2', |
168 | ); |
169 | |
296248c3 |
170 | grab_pkg_gen("DBICTest::AttrTest"); |
171 | |
5ab72593 |
172 | # and that double-application also works |
173 | attributes->import( |
174 | 'DBICTest::AttrTest', |
175 | DBICTest::AttrTest->can('attr'), |
176 | 'DBIC_attr2', |
177 | 'DBIC_attr3', |
178 | ); |
179 | |
296248c3 |
180 | grab_pkg_gen("DBICTest::AttrTest"); |
181 | |
5ab72593 |
182 | is_deeply |
183 | [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], |
184 | [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )], |
185 | 'DBIC-specific attribute installed', |
296248c3 |
186 | ; |
5ab72593 |
187 | |
188 | ok( |
189 | ! DBICTest::AttrTest->can('__attr_cache'), |
190 | 'Inherited classdata never created on core+DBIC-specific attrs' |
191 | ); |
192 | |
193 | is_deeply( |
194 | DBICTest::AttrTest->_attr_cache, |
195 | {}, |
196 | 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs' |
7bd921c0 |
197 | ); |
7bd921c0 |
198 | |
296248c3 |
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}; |
202 | |
203 | for my $i ( 1 .. $#$stack ) { |
204 | cmp_ok( |
205 | $stack->[$i-1][0], |
206 | ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ), |
207 | $stack->[$i][0], |
208 | "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]" |
209 | ); |
210 | } |
211 | } |
212 | |
213 | my $cnt; |
214 | # check that class description is stable, and changes when needed |
1c179556 |
215 | # |
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 |
219 | # |
296248c3 |
220 | for my $class (qw( |
221 | DBICTest::AttrTest |
222 | DBICTest::AttrLegacy |
223 | DBIx::Class |
296248c3 |
224 | )) { |
225 | my $desc = describe_class_methods($class); |
226 | |
227 | is_deeply( |
228 | describe_class_methods($class), |
229 | $desc, |
230 | "describe_class_methods result is stable over '$class' (pass $_)" |
231 | ) for (1,2,3); |
232 | |
233 | my $desc2 = do { |
296248c3 |
234 | no strict 'refs'; |
235 | |
236 | $cnt++; |
237 | |
d01688cc |
238 | eval "sub UEBERVERSAL::some_unimethod_$cnt {}; 1" or die $@; |
296248c3 |
239 | |
240 | my $rv = describe_class_methods($class); |
241 | |
d01688cc |
242 | delete ${"UEBERVERSAL::"}{"some_unimethod_$cnt"}; |
296248c3 |
243 | |
244 | $rv |
245 | }; |
246 | |
247 | delete $_->{cumulative_gen} for $desc, $desc2; |
248 | ok( |
249 | serialize( $desc ) |
250 | ne |
251 | serialize( $desc2 ), |
252 | "touching UNIVERSAL changed '$class' method availability" |
253 | ); |
254 | } |
255 | |
256 | my $bottom_most_V_D_C_A = refdesc( |
257 | describe_class_methods("DBIx::Class::MethodAttributes") |
258 | ->{methods} |
259 | ->{VALID_DBIC_CODE_ATTRIBUTE} |
260 | ->[0] |
261 | ); |
262 | |
263 | for my $class ( shuffle( qw( |
264 | DBICTest::AttrTest |
265 | DBICTest::AttrLegacy |
266 | DBICTest::SomeGrandParentClass |
267 | DBIx::Class::Schema |
268 | DBIx::Class::ResultSet |
269 | DBICTest::Schema::Track |
270 | ))) { |
271 | my $desc = describe_class_methods($class); |
272 | |
273 | is ( |
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" |
277 | ); |
278 | |
279 | is ( |
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}; |
284 | } |
285 | |
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 |
293 | )]; |
294 | |
295 | my $expected_desc = { |
296 | class => "DBICTest::AttrTest", |
297 | |
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); |
303 | |
304 | $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for ( |
d01688cc |
305 | 'UEBERVERSAL', |
296248c3 |
306 | 'UNIVERSAL', |
307 | 'DBICTest::AttrTest', |
308 | @$expected_AttrTest_ISA, |
309 | ); |
310 | |
311 | $gen; |
312 | }, |
313 | mro => { |
314 | type => 'c3', |
315 | is_c3 => 1, |
316 | }, |
317 | isa => $expected_AttrTest_ISA, |
318 | methods => { |
319 | FETCH_CODE_ATTRIBUTES => [ |
320 | { |
321 | attributes => {}, |
322 | name => "FETCH_CODE_ATTRIBUTES", |
323 | via_class => "DBIx::Class::MethodAttributes" |
324 | }, |
325 | ], |
326 | MODIFY_CODE_ATTRIBUTES => [ |
327 | { |
328 | attributes => {}, |
329 | name => "MODIFY_CODE_ATTRIBUTES", |
330 | via_class => "DBIx::Class::MethodAttributes" |
331 | }, |
332 | ], |
1c179556 |
333 | VALID_DBIC_CODE_ATTRIBUTE => ( my $V_D_C_A_stack = [ |
334 | { |
335 | attributes => {}, |
336 | name => 'VALID_DBIC_CODE_ATTRIBUTE', |
337 | via_class => 'DBICTest::AttrTest' |
338 | }, |
296248c3 |
339 | { |
340 | attributes => {}, |
341 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
342 | via_class => "DBICTest::SomeGrandParentClass", |
343 | }, |
344 | { |
345 | attributes => {}, |
346 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
347 | via_class => "DBICTest::AnotherParentClass" |
348 | }, |
349 | { |
350 | attributes => {}, |
351 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
352 | via_class => "DBIx::Class::MethodAttributes" |
353 | }, |
1c179556 |
354 | ]), |
296248c3 |
355 | _attr_cache => [ |
356 | { |
357 | attributes => {}, |
358 | name => "_attr_cache", |
359 | via_class => "DBIx::Class::MethodAttributes" |
360 | }, |
361 | ], |
362 | attr => [ |
363 | { |
364 | attributes => { |
365 | DBIC_attr1 => 1, |
366 | DBIC_attr2 => 1, |
367 | DBIC_attr3 => 1, |
368 | lvalue => 1, |
369 | method => 1 |
370 | }, |
371 | name => "attr", |
372 | via_class => "DBICTest::AttrTest" |
373 | } |
374 | ], |
d01688cc |
375 | ueber => [ |
376 | { |
377 | attributes => {}, |
378 | name => "ueber", |
379 | via_class => "UEBERVERSAL", |
380 | } |
381 | ], |
296248c3 |
382 | can => [ |
383 | { |
384 | attributes => {}, |
385 | name => "can", |
386 | via_class => "UNIVERSAL", |
387 | }, |
388 | ], |
389 | isa => [ |
390 | { |
391 | attributes => {}, |
392 | name => "isa", |
393 | via_class => "UNIVERSAL", |
394 | }, |
395 | ], |
396 | VERSION => [ |
397 | { |
398 | attributes => {}, |
399 | name => "VERSION", |
400 | via_class => "UNIVERSAL", |
401 | }, |
402 | ], |
403 | ( DBIx::Class::_ENV_::OLD_MRO ? () : ( |
404 | DOES => [{ |
405 | attributes => {}, |
406 | name => "DOES", |
407 | via_class => "UNIVERSAL", |
408 | }], |
409 | ) ), |
410 | }, |
411 | }; |
412 | |
413 | $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE} |
1c179556 |
414 | = $V_D_C_A_stack; |
415 | |
416 | $expected_desc->{methods_defined_in_class}{VALID_DBIC_CODE_ATTRIBUTE} |
417 | = $V_D_C_A_stack->[0]; |
296248c3 |
418 | |
085dbdd6 |
419 | $expected_desc->{methods_defined_in_class}{attr} |
420 | = $expected_desc->{methods}{attr}[0]; |
421 | |
296248c3 |
422 | is_deeply ( |
423 | describe_class_methods("DBICTest::AttrTest"), |
424 | $expected_desc, |
425 | 'describe_class_methods returns correct data', |
426 | ); |
1cf2ad8b |
427 | |
428 | # ensure that asking with a different MRO will not perturb the cache |
429 | my $cached_desc = serialize( |
430 | $DBIx::Class::_Util::describe_class_query_cache->{"DBICTest::AttrTest|c3"} |
431 | ); |
432 | |
433 | # now try to ask for DFS explicitly, adjust our expectations |
434 | $expected_desc->{mro} = { type => 'dfs', is_c3 => 0 }; |
435 | |
436 | # due to DFS the last 2 entries of ISA and the VALID_DBIC_CODE_ATTRIBUTE |
437 | # sourcing-list will change places |
438 | splice @$_, -2, 2, @{$_}[-1, -2] |
439 | for $V_D_C_A_stack, $expected_AttrTest_ISA; |
440 | |
441 | is_deeply ( |
442 | # work around taint, see TODO below |
443 | { |
444 | %{describe_class_methods("DBICTest::AttrTest", "dfs")}, |
445 | cumulative_gen => $expected_desc->{cumulative_gen}, |
446 | }, |
447 | $expected_desc, |
448 | 'describing with explicit mro returns correct data' |
449 | ); |
450 | |
451 | # FIXME: TODO does not work on new T::B under threads sigh |
452 | # https://github.com/Test-More/test-more/issues/683 |
453 | unless( |
454 | ! DBIx::Class::_ENV_::OLD_MRO |
455 | and |
456 | ${^TAINT} |
457 | ) { |
458 | #local $TODO = "On 5.10+ -T combined with stash peeking invalidates the pkg_gen (wtf)" if ... |
459 | |
460 | ok( |
461 | ( |
462 | serialize( describe_class_methods("DBICTest::AttrTest") ) |
463 | eq |
464 | $cached_desc |
465 | ), |
466 | "Asking for alternative mro type did not invalidate cache" |
467 | ); |
468 | } |
469 | |
470 | # setting mro explicitly still matches what we expect |
471 | mro::set_mro("DBICTest::AttrTest", "dfs"); |
472 | |
473 | is_deeply ( |
474 | # in case set_mro starts increasing pkg_gen... |
475 | { |
476 | %{describe_class_methods("DBICTest::AttrTest")}, |
477 | cumulative_gen => $expected_desc->{cumulative_gen}, |
478 | }, |
479 | $expected_desc, |
480 | 'describing with implicit mro returns correct data' |
481 | ); |
296248c3 |
482 | } |
7bd921c0 |
483 | |
484 | if ($skip_threads) { |
485 | SKIP: { skip "Skipping the thread test: $skip_threads", 1 } |
486 | |
487 | add_more_attrs(); |
488 | } |
296248c3 |
489 | else { SKIP: { |
490 | |
491 | my $t = threads->create(sub { |
0130575a |
492 | |
296248c3 |
493 | my $t = threads->create(sub { |
0130575a |
494 | |
495 | add_more_attrs(); |
496 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
497 | |
296248c3 |
498 | 42; |
499 | |
500 | }) || do { |
501 | die "Unable to start thread: $!" |
502 | unless $! == Errno::EAGAIN(); |
503 | |
504 | SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 } |
505 | |
506 | return 42 ; |
507 | }; |
508 | |
509 | my $rv = $t->join; |
0130575a |
510 | |
7bd921c0 |
511 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
0130575a |
512 | |
296248c3 |
513 | $rv; |
514 | }) || do { |
515 | die "Unable to start thread: $!" |
516 | unless $! == Errno::EAGAIN(); |
517 | |
518 | skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1; |
519 | }; |
520 | |
521 | is ( |
522 | $t->join, |
523 | 42, |
524 | 'Thread stack exitted succesfully' |
525 | ); |
526 | }} |
7bd921c0 |
527 | |
085dbdd6 |
528 | # this doesn't really belong in this test, but screw it |
529 | { |
530 | package DBICTest::WackyDFS; |
531 | use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass ); |
532 | } |
533 | |
534 | is_deeply |
535 | describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE}, |
536 | [ |
537 | { |
538 | attributes => {}, |
539 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
540 | via_class => "DBICTest::SomeGrandParentClass", |
541 | }, |
542 | { |
543 | attributes => {}, |
544 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
545 | via_class => "DBIx::Class::MethodAttributes" |
546 | }, |
547 | ], |
548 | 'Expected description on unusable inheritance hierarchy' |
549 | ; |
550 | |
7bd921c0 |
551 | done_testing; |