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 ) |
2603b495 |
289 | my $expected_AttrTest_linear_ISA = [qw( |
296248c3 |
290 | DBICTest::SomeParentClass |
291 | DBICTest::SomeGrandParentClass |
292 | DBICTest::AnotherParentClass |
293 | DBIx::Class::MethodAttributes |
294 | )]; |
295 | |
2603b495 |
296 | my $expected_AttrTest_full_ISA = { map { $_ => 1 } ( |
297 | qw( UEBERVERSAL UNIVERSAL DBICTest::AttrTest ), |
298 | @$expected_AttrTest_linear_ISA, |
299 | )}; |
300 | |
296248c3 |
301 | my $expected_desc = { |
302 | class => "DBICTest::AttrTest", |
303 | |
304 | # sum and/or is_deeply are buggy on old List::Util/Test::More |
305 | # do the sum by hand ourselves to be sure |
306 | cumulative_gen => do { |
307 | require Math::BigInt; |
308 | my $gen = Math::BigInt->new(0); |
309 | |
2603b495 |
310 | $gen += DBIx::Class::_Util::get_real_pkg_gen($_) |
311 | for keys %$expected_AttrTest_full_ISA; |
296248c3 |
312 | |
313 | $gen; |
314 | }, |
315 | mro => { |
316 | type => 'c3', |
317 | is_c3 => 1, |
318 | }, |
2603b495 |
319 | linear_isa => $expected_AttrTest_linear_ISA, |
320 | isa => $expected_AttrTest_full_ISA, |
296248c3 |
321 | methods => { |
322 | FETCH_CODE_ATTRIBUTES => [ |
323 | { |
324 | attributes => {}, |
325 | name => "FETCH_CODE_ATTRIBUTES", |
326 | via_class => "DBIx::Class::MethodAttributes" |
327 | }, |
328 | ], |
329 | MODIFY_CODE_ATTRIBUTES => [ |
330 | { |
331 | attributes => {}, |
332 | name => "MODIFY_CODE_ATTRIBUTES", |
333 | via_class => "DBIx::Class::MethodAttributes" |
334 | }, |
335 | ], |
1c179556 |
336 | VALID_DBIC_CODE_ATTRIBUTE => ( my $V_D_C_A_stack = [ |
337 | { |
338 | attributes => {}, |
339 | name => 'VALID_DBIC_CODE_ATTRIBUTE', |
340 | via_class => 'DBICTest::AttrTest' |
341 | }, |
296248c3 |
342 | { |
343 | attributes => {}, |
344 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
345 | via_class => "DBICTest::SomeGrandParentClass", |
346 | }, |
347 | { |
348 | attributes => {}, |
349 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
350 | via_class => "DBICTest::AnotherParentClass" |
351 | }, |
352 | { |
353 | attributes => {}, |
354 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
355 | via_class => "DBIx::Class::MethodAttributes" |
356 | }, |
1c179556 |
357 | ]), |
296248c3 |
358 | _attr_cache => [ |
359 | { |
360 | attributes => {}, |
361 | name => "_attr_cache", |
362 | via_class => "DBIx::Class::MethodAttributes" |
363 | }, |
364 | ], |
365 | attr => [ |
366 | { |
367 | attributes => { |
368 | DBIC_attr1 => 1, |
369 | DBIC_attr2 => 1, |
370 | DBIC_attr3 => 1, |
371 | lvalue => 1, |
372 | method => 1 |
373 | }, |
374 | name => "attr", |
375 | via_class => "DBICTest::AttrTest" |
376 | } |
377 | ], |
d01688cc |
378 | ueber => [ |
379 | { |
380 | attributes => {}, |
381 | name => "ueber", |
382 | via_class => "UEBERVERSAL", |
383 | } |
384 | ], |
c47451b7 |
385 | uni => [ |
386 | { |
387 | attributes => {}, |
388 | name => "uni", |
389 | via_class => "UNIVERSAL", |
390 | } |
391 | ], |
296248c3 |
392 | can => [ |
393 | { |
394 | attributes => {}, |
395 | name => "can", |
396 | via_class => "UNIVERSAL", |
397 | }, |
398 | ], |
399 | isa => [ |
400 | { |
401 | attributes => {}, |
402 | name => "isa", |
403 | via_class => "UNIVERSAL", |
404 | }, |
405 | ], |
406 | VERSION => [ |
407 | { |
408 | attributes => {}, |
409 | name => "VERSION", |
410 | via_class => "UNIVERSAL", |
411 | }, |
412 | ], |
413 | ( DBIx::Class::_ENV_::OLD_MRO ? () : ( |
414 | DOES => [{ |
415 | attributes => {}, |
416 | name => "DOES", |
417 | via_class => "UNIVERSAL", |
418 | }], |
419 | ) ), |
420 | }, |
421 | }; |
422 | |
423 | $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE} |
1c179556 |
424 | = $V_D_C_A_stack; |
425 | |
426 | $expected_desc->{methods_defined_in_class}{VALID_DBIC_CODE_ATTRIBUTE} |
427 | = $V_D_C_A_stack->[0]; |
296248c3 |
428 | |
085dbdd6 |
429 | $expected_desc->{methods_defined_in_class}{attr} |
430 | = $expected_desc->{methods}{attr}[0]; |
431 | |
296248c3 |
432 | is_deeply ( |
433 | describe_class_methods("DBICTest::AttrTest"), |
434 | $expected_desc, |
435 | 'describe_class_methods returns correct data', |
436 | ); |
1cf2ad8b |
437 | |
438 | # ensure that asking with a different MRO will not perturb the cache |
439 | my $cached_desc = serialize( |
440 | $DBIx::Class::_Util::describe_class_query_cache->{"DBICTest::AttrTest|c3"} |
441 | ); |
442 | |
443 | # now try to ask for DFS explicitly, adjust our expectations |
444 | $expected_desc->{mro} = { type => 'dfs', is_c3 => 0 }; |
445 | |
446 | # due to DFS the last 2 entries of ISA and the VALID_DBIC_CODE_ATTRIBUTE |
447 | # sourcing-list will change places |
448 | splice @$_, -2, 2, @{$_}[-1, -2] |
2603b495 |
449 | for $V_D_C_A_stack, $expected_AttrTest_linear_ISA; |
1cf2ad8b |
450 | |
451 | is_deeply ( |
452 | # work around taint, see TODO below |
453 | { |
8eac247d |
454 | %{ describe_class_methods({ class => "DBICTest::AttrTest", use_mro => "dfs" }) }, |
1cf2ad8b |
455 | cumulative_gen => $expected_desc->{cumulative_gen}, |
456 | }, |
457 | $expected_desc, |
458 | 'describing with explicit mro returns correct data' |
459 | ); |
460 | |
461 | # FIXME: TODO does not work on new T::B under threads sigh |
462 | # https://github.com/Test-More/test-more/issues/683 |
463 | unless( |
464 | ! DBIx::Class::_ENV_::OLD_MRO |
465 | and |
466 | ${^TAINT} |
467 | ) { |
468 | #local $TODO = "On 5.10+ -T combined with stash peeking invalidates the pkg_gen (wtf)" if ... |
469 | |
470 | ok( |
471 | ( |
472 | serialize( describe_class_methods("DBICTest::AttrTest") ) |
473 | eq |
474 | $cached_desc |
475 | ), |
476 | "Asking for alternative mro type did not invalidate cache" |
477 | ); |
478 | } |
479 | |
480 | # setting mro explicitly still matches what we expect |
481 | mro::set_mro("DBICTest::AttrTest", "dfs"); |
482 | |
483 | is_deeply ( |
484 | # in case set_mro starts increasing pkg_gen... |
485 | { |
486 | %{describe_class_methods("DBICTest::AttrTest")}, |
487 | cumulative_gen => $expected_desc->{cumulative_gen}, |
488 | }, |
489 | $expected_desc, |
490 | 'describing with implicit mro returns correct data' |
491 | ); |
c47451b7 |
492 | |
493 | # check that a UNIVERSAL-parent interrogation makes sense |
494 | # ( it should not list anything from UNIVERSAL itself ) |
495 | is_deeply ( |
496 | describe_class_methods("UEBERVERSAL"), |
497 | { |
498 | # should be cached by now, thus safe to rely on...? |
499 | cumulative_gen => DBIx::Class::_Util::get_real_pkg_gen('UEBERVERSAL'), |
500 | |
501 | class => 'UEBERVERSAL', |
502 | mro => { is_c3 => 0, type => 'dfs' }, |
2603b495 |
503 | isa => { UEBERVERSAL => 1 }, |
504 | linear_isa => [], |
c47451b7 |
505 | methods => { |
506 | ueber => $expected_desc->{methods}{ueber} |
507 | }, |
508 | methods_defined_in_class => { |
509 | ueber => $expected_desc->{methods}{ueber}[0] |
510 | }, |
511 | }, |
512 | "Expected description of a parent-of-UNIVERSAL class (pathological case)", |
513 | ); |
296248c3 |
514 | } |
7bd921c0 |
515 | |
516 | if ($skip_threads) { |
517 | SKIP: { skip "Skipping the thread test: $skip_threads", 1 } |
518 | |
519 | add_more_attrs(); |
520 | } |
296248c3 |
521 | else { SKIP: { |
522 | |
523 | my $t = threads->create(sub { |
0130575a |
524 | |
296248c3 |
525 | my $t = threads->create(sub { |
0130575a |
526 | |
527 | add_more_attrs(); |
528 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
529 | |
296248c3 |
530 | 42; |
531 | |
532 | }) || do { |
533 | die "Unable to start thread: $!" |
534 | unless $! == Errno::EAGAIN(); |
535 | |
536 | SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 } |
537 | |
538 | return 42 ; |
539 | }; |
540 | |
541 | my $rv = $t->join; |
0130575a |
542 | |
7bd921c0 |
543 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
0130575a |
544 | |
296248c3 |
545 | $rv; |
546 | }) || do { |
547 | die "Unable to start thread: $!" |
548 | unless $! == Errno::EAGAIN(); |
549 | |
550 | skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1; |
551 | }; |
552 | |
553 | is ( |
554 | $t->join, |
555 | 42, |
556 | 'Thread stack exitted succesfully' |
557 | ); |
558 | }} |
7bd921c0 |
559 | |
085dbdd6 |
560 | # this doesn't really belong in this test, but screw it |
561 | { |
562 | package DBICTest::WackyDFS; |
563 | use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass ); |
564 | } |
565 | |
566 | is_deeply |
567 | describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE}, |
568 | [ |
569 | { |
570 | attributes => {}, |
571 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
572 | via_class => "DBICTest::SomeGrandParentClass", |
573 | }, |
574 | { |
575 | attributes => {}, |
576 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
577 | via_class => "DBIx::Class::MethodAttributes" |
578 | }, |
579 | ], |
580 | 'Expected description on unusable inheritance hierarchy' |
581 | ; |
582 | |
7bd921c0 |
583 | done_testing; |