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 | ); |
427 | } |
7bd921c0 |
428 | |
429 | if ($skip_threads) { |
430 | SKIP: { skip "Skipping the thread test: $skip_threads", 1 } |
431 | |
432 | add_more_attrs(); |
433 | } |
296248c3 |
434 | else { SKIP: { |
435 | |
436 | my $t = threads->create(sub { |
0130575a |
437 | |
296248c3 |
438 | my $t = threads->create(sub { |
0130575a |
439 | |
440 | add_more_attrs(); |
441 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
442 | |
296248c3 |
443 | 42; |
444 | |
445 | }) || do { |
446 | die "Unable to start thread: $!" |
447 | unless $! == Errno::EAGAIN(); |
448 | |
449 | SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 } |
450 | |
451 | return 42 ; |
452 | }; |
453 | |
454 | my $rv = $t->join; |
0130575a |
455 | |
7bd921c0 |
456 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
0130575a |
457 | |
296248c3 |
458 | $rv; |
459 | }) || do { |
460 | die "Unable to start thread: $!" |
461 | unless $! == Errno::EAGAIN(); |
462 | |
463 | skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1; |
464 | }; |
465 | |
466 | is ( |
467 | $t->join, |
468 | 42, |
469 | 'Thread stack exitted succesfully' |
470 | ); |
471 | }} |
7bd921c0 |
472 | |
085dbdd6 |
473 | # this doesn't really belong in this test, but screw it |
474 | { |
475 | package DBICTest::WackyDFS; |
476 | use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass ); |
477 | } |
478 | |
479 | is_deeply |
480 | describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE}, |
481 | [ |
482 | { |
483 | attributes => {}, |
484 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
485 | via_class => "DBICTest::SomeGrandParentClass", |
486 | }, |
487 | { |
488 | attributes => {}, |
489 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
490 | via_class => "DBIx::Class::MethodAttributes" |
491 | }, |
492 | ], |
493 | 'Expected description on unusable inheritance hierarchy' |
494 | ; |
495 | |
7bd921c0 |
496 | done_testing; |