Commit | Line | Data |
296248c3 |
1 | BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } |
2 | |
7bd921c0 |
3 | use warnings; |
4 | use strict; |
5 | |
6 | use Config; |
7 | my $skip_threads; |
8 | BEGIN { |
9 | if( ! $Config{useithreads} ) { |
10 | $skip_threads = 'your perl does not support ithreads'; |
11 | } |
12 | elsif( "$]" < 5.008005 ) { |
13 | $skip_threads = 'DBIC does not actively support threads before perl 5.8.5'; |
14 | } |
15 | elsif( $INC{'Devel/Cover.pm'} ) { |
16 | $skip_threads = 'Devel::Cover does not work with ithreads yet'; |
17 | } |
18 | |
19 | unless( $skip_threads ) { |
20 | require threads; |
21 | threads->import; |
22 | } |
23 | } |
24 | |
25 | use Test::More; |
5ab72593 |
26 | use Test::Exception; |
296248c3 |
27 | use DBIx::Class::_Util qw( quote_sub describe_class_methods serialize refdesc ); |
28 | use List::Util 'shuffle'; |
29 | use Errno (); |
30 | |
31 | use DBICTest; |
32 | |
33 | my $pkg_gen_history = {}; |
34 | |
35 | sub grab_pkg_gen ($) { |
36 | push @{ $pkg_gen_history->{$_[0]} }, [ |
37 | DBIx::Class::_Util::get_real_pkg_gen($_[0]), |
38 | 'line ' . ( (caller(0))[2] ), |
39 | ]; |
40 | } |
7bd921c0 |
41 | |
5ab72593 |
42 | @DBICTest::AttrLegacy::ISA = 'DBIx::Class'; |
43 | sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 } |
7bd921c0 |
44 | |
296248c3 |
45 | grab_pkg_gen("DBICTest::AttrLegacy"); |
46 | |
7bd921c0 |
47 | my $var = \42; |
48 | my $s = quote_sub( |
5ab72593 |
49 | 'DBICTest::AttrLegacy::attr', |
7bd921c0 |
50 | '$v', |
51 | { '$v' => $var }, |
52 | { |
5ab72593 |
53 | attributes => [qw( ResultSet DBIC_random_attr )], |
54 | package => 'DBICTest::AttrLegacy', |
7bd921c0 |
55 | }, |
56 | ); |
57 | |
296248c3 |
58 | grab_pkg_gen("DBICTest::AttrLegacy"); |
59 | |
5ab72593 |
60 | is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed'; |
7bd921c0 |
61 | |
5ab72593 |
62 | is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable'; |
7bd921c0 |
63 | |
64 | is_deeply |
5ab72593 |
65 | [ sort( attributes::get( $s ) ) ], |
66 | [qw( DBIC_random_attr ResultSet )], |
7bd921c0 |
67 | 'Attribute installed', |
296248c3 |
68 | ; |
7bd921c0 |
69 | |
296248c3 |
70 | { |
71 | package DBICTest::SomeGrandParentClass; |
72 | use base 'DBIx::Class::MethodAttributes'; |
73 | sub VALID_DBIC_CODE_ATTRIBUTE { shift->next::method(@_) }; |
74 | } |
75 | { |
76 | package DBICTest::SomeParentClass; |
77 | use base qw(DBICTest::SomeGrandParentClass); |
78 | } |
79 | { |
80 | package DBICTest::AnotherParentClass; |
81 | use base 'DBIx::Class::MethodAttributes'; |
82 | sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ }; |
83 | } |
5ab72593 |
84 | |
5ab72593 |
85 | { |
296248c3 |
86 | package DBICTest::AttrTest; |
87 | |
88 | @DBICTest::AttrTest::ISA = qw( DBICTest::SomeParentClass DBICTest::AnotherParentClass ); |
89 | use mro 'c3'; |
90 | |
91 | ::grab_pkg_gen("DBICTest::AttrTest"); |
5ab72593 |
92 | |
296248c3 |
93 | eval <<'EOS' or die $@; |
5ab72593 |
94 | sub attr :lvalue :method :DBIC_attr1 { $$var} |
95 | 1; |
96 | EOS |
97 | |
296248c3 |
98 | ::grab_pkg_gen("DBICTest::AttrTest"); |
99 | |
100 | ::throws_ok { |
101 | attributes->import( |
102 | 'DBICTest::AttrTest', |
103 | DBICTest::AttrTest->can('attr'), |
104 | 'DBIC_unknownattr', |
105 | ); |
106 | } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/; |
5ab72593 |
107 | } |
108 | |
109 | is_deeply |
110 | [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], |
111 | [qw( DBIC_attr1 lvalue method )], |
112 | 'Attribute installed', |
296248c3 |
113 | ; |
5ab72593 |
114 | |
115 | ok( |
116 | ! DBICTest::AttrTest->can('__attr_cache'), |
117 | 'Inherited classdata never created on core attrs' |
118 | ); |
119 | |
120 | is_deeply( |
121 | DBICTest::AttrTest->_attr_cache, |
122 | {}, |
123 | 'Cache never instantiated on core attrs' |
124 | ); |
125 | |
7bd921c0 |
126 | sub add_more_attrs { |
296248c3 |
127 | |
7bd921c0 |
128 | # Test that secondary attribute application works |
129 | attributes->import( |
5ab72593 |
130 | 'DBICTest::AttrLegacy', |
131 | DBICTest::AttrLegacy->can('attr'), |
7bd921c0 |
132 | 'SomethingNobodyUses', |
133 | ); |
134 | |
135 | # and that double-application also works |
136 | attributes->import( |
5ab72593 |
137 | 'DBICTest::AttrLegacy', |
138 | DBICTest::AttrLegacy->can('attr'), |
7bd921c0 |
139 | 'SomethingNobodyUses', |
140 | ); |
141 | |
296248c3 |
142 | grab_pkg_gen("DBICTest::AttrLegacy"); |
143 | |
7bd921c0 |
144 | is_deeply |
145 | [ sort( attributes::get( $s ) )], |
5ab72593 |
146 | [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ], |
7bd921c0 |
147 | 'Secondary attributes installed', |
296248c3 |
148 | ; |
7bd921c0 |
149 | |
150 | is_deeply ( |
5ab72593 |
151 | DBICTest::AttrLegacy->_attr_cache->{$s}, |
152 | [ qw( ResultSet SomethingNobodyUses ) ], |
153 | 'Attributes visible in legacy DBIC attribute API', |
154 | ); |
155 | |
5ab72593 |
156 | # Test that secondary attribute application works |
157 | attributes->import( |
158 | 'DBICTest::AttrTest', |
159 | DBICTest::AttrTest->can('attr'), |
160 | 'DBIC_attr2', |
161 | ); |
162 | |
296248c3 |
163 | grab_pkg_gen("DBICTest::AttrTest"); |
164 | |
5ab72593 |
165 | # and that double-application also works |
166 | attributes->import( |
167 | 'DBICTest::AttrTest', |
168 | DBICTest::AttrTest->can('attr'), |
169 | 'DBIC_attr2', |
170 | 'DBIC_attr3', |
171 | ); |
172 | |
296248c3 |
173 | grab_pkg_gen("DBICTest::AttrTest"); |
174 | |
5ab72593 |
175 | is_deeply |
176 | [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], |
177 | [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )], |
178 | 'DBIC-specific attribute installed', |
296248c3 |
179 | ; |
5ab72593 |
180 | |
181 | ok( |
182 | ! DBICTest::AttrTest->can('__attr_cache'), |
183 | 'Inherited classdata never created on core+DBIC-specific attrs' |
184 | ); |
185 | |
186 | is_deeply( |
187 | DBICTest::AttrTest->_attr_cache, |
188 | {}, |
189 | 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs' |
7bd921c0 |
190 | ); |
7bd921c0 |
191 | |
296248c3 |
192 | # no point dragging in threads::shared, just do the check here |
193 | for my $class ( keys %$pkg_gen_history ) { |
194 | my $stack = $pkg_gen_history->{$class}; |
195 | |
196 | for my $i ( 1 .. $#$stack ) { |
197 | cmp_ok( |
198 | $stack->[$i-1][0], |
199 | ( DBIx::Class::_ENV_::OLD_MRO ? '!=' : '<' ), |
200 | $stack->[$i][0], |
201 | "pkg_gen for $class changed from $stack->[$i-1][1] to $stack->[$i][1]" |
202 | ); |
203 | } |
204 | } |
205 | |
206 | my $cnt; |
207 | # check that class description is stable, and changes when needed |
208 | for my $class (qw( |
209 | DBICTest::AttrTest |
210 | DBICTest::AttrLegacy |
211 | DBIx::Class |
212 | main |
213 | )) { |
214 | my $desc = describe_class_methods($class); |
215 | |
216 | is_deeply( |
217 | describe_class_methods($class), |
218 | $desc, |
219 | "describe_class_methods result is stable over '$class' (pass $_)" |
220 | ) for (1,2,3); |
221 | |
222 | my $desc2 = do { |
223 | no warnings 'once'; |
224 | no strict 'refs'; |
225 | |
226 | $cnt++; |
227 | |
228 | eval "sub UNIVERSAL::some_unimethod_$cnt {}; 1" or die $@; |
229 | |
230 | my $rv = describe_class_methods($class); |
231 | |
232 | delete ${"UNIVERSAL::"}{"some_unimethod_$cnt"}; |
233 | |
234 | $rv |
235 | }; |
236 | |
237 | delete $_->{cumulative_gen} for $desc, $desc2; |
238 | ok( |
239 | serialize( $desc ) |
240 | ne |
241 | serialize( $desc2 ), |
242 | "touching UNIVERSAL changed '$class' method availability" |
243 | ); |
244 | } |
245 | |
246 | my $bottom_most_V_D_C_A = refdesc( |
247 | describe_class_methods("DBIx::Class::MethodAttributes") |
248 | ->{methods} |
249 | ->{VALID_DBIC_CODE_ATTRIBUTE} |
250 | ->[0] |
251 | ); |
252 | |
253 | for my $class ( shuffle( qw( |
254 | DBICTest::AttrTest |
255 | DBICTest::AttrLegacy |
256 | DBICTest::SomeGrandParentClass |
257 | DBIx::Class::Schema |
258 | DBIx::Class::ResultSet |
259 | DBICTest::Schema::Track |
260 | ))) { |
261 | my $desc = describe_class_methods($class); |
262 | |
263 | is ( |
264 | refdesc( $desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ), |
265 | $bottom_most_V_D_C_A, |
266 | "Same physical structure returned for last VALID_DBIC_CODE_ATTRIBUTE via class $class" |
267 | ); |
268 | |
269 | is ( |
270 | refdesc( $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}[-1] ), |
271 | $bottom_most_V_D_C_A, |
272 | "Same physical structure returned for bottom-most SUPER of VALID_DBIC_CODE_ATTRIBUTE via class $class" |
273 | ) if $desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE}; |
274 | } |
275 | |
276 | # check that describe_class_methods returns the right stuff |
277 | # ( on the simpler class ) |
278 | my $expected_AttrTest_ISA = [qw( |
279 | DBICTest::SomeParentClass |
280 | DBICTest::SomeGrandParentClass |
281 | DBICTest::AnotherParentClass |
282 | DBIx::Class::MethodAttributes |
283 | )]; |
284 | |
285 | my $expected_desc = { |
286 | class => "DBICTest::AttrTest", |
287 | |
288 | # sum and/or is_deeply are buggy on old List::Util/Test::More |
289 | # do the sum by hand ourselves to be sure |
290 | cumulative_gen => do { |
291 | require Math::BigInt; |
292 | my $gen = Math::BigInt->new(0); |
293 | |
294 | $gen += DBIx::Class::_Util::get_real_pkg_gen($_) for ( |
295 | 'UNIVERSAL', |
296 | 'DBICTest::AttrTest', |
297 | @$expected_AttrTest_ISA, |
298 | ); |
299 | |
300 | $gen; |
301 | }, |
302 | mro => { |
303 | type => 'c3', |
304 | is_c3 => 1, |
305 | }, |
306 | isa => $expected_AttrTest_ISA, |
307 | methods => { |
308 | FETCH_CODE_ATTRIBUTES => [ |
309 | { |
310 | attributes => {}, |
311 | name => "FETCH_CODE_ATTRIBUTES", |
312 | via_class => "DBIx::Class::MethodAttributes" |
313 | }, |
314 | ], |
315 | MODIFY_CODE_ATTRIBUTES => [ |
316 | { |
317 | attributes => {}, |
318 | name => "MODIFY_CODE_ATTRIBUTES", |
319 | via_class => "DBIx::Class::MethodAttributes" |
320 | }, |
321 | ], |
322 | VALID_DBIC_CODE_ATTRIBUTE => [ |
323 | { |
324 | attributes => {}, |
325 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
326 | via_class => "DBICTest::SomeGrandParentClass", |
327 | }, |
328 | { |
329 | attributes => {}, |
330 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
331 | via_class => "DBICTest::AnotherParentClass" |
332 | }, |
333 | { |
334 | attributes => {}, |
335 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
336 | via_class => "DBIx::Class::MethodAttributes" |
337 | }, |
338 | ], |
339 | _attr_cache => [ |
340 | { |
341 | attributes => {}, |
342 | name => "_attr_cache", |
343 | via_class => "DBIx::Class::MethodAttributes" |
344 | }, |
345 | ], |
346 | attr => [ |
347 | { |
348 | attributes => { |
349 | DBIC_attr1 => 1, |
350 | DBIC_attr2 => 1, |
351 | DBIC_attr3 => 1, |
352 | lvalue => 1, |
353 | method => 1 |
354 | }, |
355 | name => "attr", |
356 | via_class => "DBICTest::AttrTest" |
357 | } |
358 | ], |
359 | can => [ |
360 | { |
361 | attributes => {}, |
362 | name => "can", |
363 | via_class => "UNIVERSAL", |
364 | }, |
365 | ], |
366 | isa => [ |
367 | { |
368 | attributes => {}, |
369 | name => "isa", |
370 | via_class => "UNIVERSAL", |
371 | }, |
372 | ], |
373 | VERSION => [ |
374 | { |
375 | attributes => {}, |
376 | name => "VERSION", |
377 | via_class => "UNIVERSAL", |
378 | }, |
379 | ], |
380 | ( DBIx::Class::_ENV_::OLD_MRO ? () : ( |
381 | DOES => [{ |
382 | attributes => {}, |
383 | name => "DOES", |
384 | via_class => "UNIVERSAL", |
385 | }], |
386 | ) ), |
387 | }, |
388 | }; |
389 | |
390 | $expected_desc->{methods_with_supers}{VALID_DBIC_CODE_ATTRIBUTE} |
391 | = $expected_desc->{methods}{VALID_DBIC_CODE_ATTRIBUTE}; |
392 | |
085dbdd6 |
393 | $expected_desc->{methods_defined_in_class}{attr} |
394 | = $expected_desc->{methods}{attr}[0]; |
395 | |
296248c3 |
396 | is_deeply ( |
397 | describe_class_methods("DBICTest::AttrTest"), |
398 | $expected_desc, |
399 | 'describe_class_methods returns correct data', |
400 | ); |
401 | } |
7bd921c0 |
402 | |
403 | if ($skip_threads) { |
404 | SKIP: { skip "Skipping the thread test: $skip_threads", 1 } |
405 | |
406 | add_more_attrs(); |
407 | } |
296248c3 |
408 | else { SKIP: { |
409 | |
410 | my $t = threads->create(sub { |
0130575a |
411 | |
296248c3 |
412 | my $t = threads->create(sub { |
0130575a |
413 | |
414 | add_more_attrs(); |
415 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
416 | |
296248c3 |
417 | 42; |
418 | |
419 | }) || do { |
420 | die "Unable to start thread: $!" |
421 | unless $! == Errno::EAGAIN(); |
422 | |
423 | SKIP: { skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1 } |
424 | |
425 | return 42 ; |
426 | }; |
427 | |
428 | my $rv = $t->join; |
0130575a |
429 | |
7bd921c0 |
430 | select( undef, undef, undef, 0.2 ); # without this many tasty crashes even on latest perls |
0130575a |
431 | |
296248c3 |
432 | $rv; |
433 | }) || do { |
434 | die "Unable to start thread: $!" |
435 | unless $! == Errno::EAGAIN(); |
436 | |
437 | skip "EAGAIN encountered, your system is likely bogged down: skipping rest of test", 1; |
438 | }; |
439 | |
440 | is ( |
441 | $t->join, |
442 | 42, |
443 | 'Thread stack exitted succesfully' |
444 | ); |
445 | }} |
7bd921c0 |
446 | |
085dbdd6 |
447 | # this doesn't really belong in this test, but screw it |
448 | { |
449 | package DBICTest::WackyDFS; |
450 | use base qw( DBICTest::SomeGrandParentClass DBICTest::SomeParentClass ); |
451 | } |
452 | |
453 | is_deeply |
454 | describe_class_methods("DBICTest::WackyDFS")->{methods}{VALID_DBIC_CODE_ATTRIBUTE}, |
455 | [ |
456 | { |
457 | attributes => {}, |
458 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
459 | via_class => "DBICTest::SomeGrandParentClass", |
460 | }, |
461 | { |
462 | attributes => {}, |
463 | name => "VALID_DBIC_CODE_ATTRIBUTE", |
464 | via_class => "DBIx::Class::MethodAttributes" |
465 | }, |
466 | ], |
467 | 'Expected description on unusable inheritance hierarchy' |
468 | ; |
469 | |
7bd921c0 |
470 | done_testing; |