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