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