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