Commit | Line | Data |
66917da3 |
1 | # work around brain damage in PPerl (yes, it has to be a global) |
2 | $SIG{__WARN__} = sub { |
3 | warn @_ unless $_[0] =~ /\QUse of "goto" to jump into a construct is deprecated/ |
4 | } if ($ENV{DBICTEST_IN_PERSISTENT_ENV}); |
5 | |
6 | # the persistent environments run with this flag first to see if |
7 | # we will run at all (e.g. it will fail if $^X doesn't match) |
8 | exit 0 if $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY}; |
9 | |
f05edfd1 |
10 | # Do the override as early as possible so that CORE::bless doesn't get compiled away |
11 | # We will replace $bless_override only if we are in author mode |
12 | my $bless_override; |
13 | BEGIN { |
14 | $bless_override = sub { |
15 | CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ); |
16 | }; |
17 | *CORE::GLOBAL::bless = sub { goto $bless_override }; |
18 | } |
19 | |
50261284 |
20 | use strict; |
21 | use warnings; |
a917fb06 |
22 | use Test::More; |
d5e5fb4b |
23 | |
66917da3 |
24 | my $TB = Test::More->builder; |
25 | if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { |
26 | # without this explicit close ->reset below warns |
27 | close ($TB->$_) for qw/output failure_output/; |
28 | |
29 | # so done_testing can work |
30 | $TB->reset; |
31 | |
32 | # this simulates a subtest |
33 | $TB->_indent(' ' x 4); |
34 | } |
35 | |
d5e5fb4b |
36 | use lib qw(t/lib); |
37 | use DBICTest::RunMode; |
e0b2dc74 |
38 | use DBIx::Class; |
dee99c24 |
39 | use B 'svref_2object'; |
d12d8272 |
40 | BEGIN { |
d5e5fb4b |
41 | plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test" |
dee99c24 |
42 | if DBIx::Class::_ENV_::PEEPEENESS; |
d12d8272 |
43 | } |
44 | |
a8c2c746 |
45 | use Scalar::Util qw/refaddr reftype weaken/; |
a917fb06 |
46 | |
a8c2c746 |
47 | # this is what holds all weakened refs to be checked for leakage |
48 | my $weak_registry = {}; |
49 | |
6a43bc0c |
50 | # whether or to invoke IC::DT |
51 | my $has_dt; |
52 | |
a8c2c746 |
53 | # Skip the heavy-duty leak tracing when just doing an install |
54 | unless (DBICTest::RunMode->is_plain) { |
f05edfd1 |
55 | |
eb7aa960 |
56 | # have our own little stack maker - Carp infloops due to the bless override |
57 | my $trace = sub { |
58 | my $depth = 1; |
59 | my (@stack, @frame); |
60 | |
61 | while (@frame = caller($depth++)) { |
62 | push @stack, [@frame[3,1,2]]; |
63 | } |
6a43bc0c |
64 | |
eb7aa960 |
65 | $stack[0][0] = ''; |
66 | return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack; |
67 | }; |
68 | |
69 | # redefine the bless override so that we can catch each and every object created |
a8c2c746 |
70 | no warnings qw/redefine once/; |
71 | no strict qw/refs/; |
72 | |
f05edfd1 |
73 | $bless_override = sub { |
74 | |
a8c2c746 |
75 | my $obj = CORE::bless( |
76 | $_[0], (@_ > 1) ? $_[1] : do { |
77 | my ($class, $fn, $line) = caller(); |
78 | fail ("bless() of $_[0] into $class without explicit class specification at $fn line $line") |
79 | if $class =~ /^ (?: DBIx\:\:Class | DBICTest ) /x; |
80 | $class; |
81 | } |
82 | ); |
83 | |
84 | my $slot = (sprintf '%s=%s(0x%x)', # so we don't trigger stringification |
85 | ref $obj, |
86 | reftype $obj, |
87 | refaddr $obj, |
88 | ); |
89 | |
90 | # weaken immediately to avoid weird side effects |
eb7aa960 |
91 | $weak_registry->{$slot} = { weakref => $obj, strace => $trace->() }; |
a8c2c746 |
92 | weaken $weak_registry->{$slot}{weakref}; |
93 | |
94 | return $obj; |
95 | }; |
96 | |
eb7aa960 |
97 | require Try::Tiny; |
a8c2c746 |
98 | for my $func (qw/try catch finally/) { |
99 | my $orig = \&{"Try::Tiny::$func"}; |
100 | *{"Try::Tiny::$func"} = sub (&;@) { |
101 | |
102 | my $slot = sprintf ('CODE(0x%x)', refaddr $_[0]); |
103 | |
eb7aa960 |
104 | $weak_registry->{$slot} = { weakref => $_[0], strace => $trace->() }; |
a8c2c746 |
105 | weaken $weak_registry->{$slot}{weakref}; |
106 | |
107 | goto $orig; |
108 | } |
109 | } |
eb7aa960 |
110 | |
111 | # Some modules are known to install singletons on-load |
112 | # Load them and empty the registry |
113 | |
114 | # this loads the DT armada |
115 | $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for('test_dt_sqlite'); |
116 | |
117 | require Errno; |
118 | require DBI; |
119 | require DBD::SQLite; |
120 | require FileHandle; |
121 | |
122 | %$weak_registry = (); |
a8c2c746 |
123 | } |
124 | |
dee99c24 |
125 | my @compose_ns_classes; |
a8c2c746 |
126 | { |
66917da3 |
127 | use_ok ('DBICTest'); |
a917fb06 |
128 | |
a8c2c746 |
129 | my $schema = DBICTest->init_schema; |
130 | my $rs = $schema->resultset ('Artist'); |
131 | my $storage = $schema->storage; |
a917fb06 |
132 | |
dee99c24 |
133 | @compose_ns_classes = map { "DBICTest::${_}" } keys %{$schema->source_registrations}; |
134 | |
a8c2c746 |
135 | ok ($storage->connected, 'we are connected'); |
a917fb06 |
136 | |
052b8ce2 |
137 | my $row_obj = $rs->search({}, { rows => 1})->next; # so that commits/rollbacks work |
a8c2c746 |
138 | ok ($row_obj, 'row from db'); |
139 | |
052b8ce2 |
140 | # txn_do to invoke more codepaths |
a8c2c746 |
141 | my ($mc_row_obj, $pager, $pager_explicit_count) = $schema->txn_do (sub { |
142 | |
143 | my $artist = $rs->create ({ |
144 | name => 'foo artist', |
145 | cds => [{ |
146 | title => 'foo cd', |
147 | year => 1984, |
187ec69a |
148 | tracks => [ |
149 | { title => 't1' }, |
150 | { title => 't2' }, |
151 | ], |
152 | genre => { name => 'mauve' }, |
a8c2c746 |
153 | }], |
154 | }); |
155 | |
156 | my $pg = $rs->search({}, { rows => 1})->page(2)->pager; |
157 | |
158 | my $pg_wcount = $rs->page(4)->pager->total_entries (66); |
159 | |
160 | return ($artist, $pg, $pg_wcount); |
161 | }); |
162 | |
187ec69a |
163 | # same for dbh_do |
164 | my ($rs_bind_circref, $cond_rowobj) = $schema->storage->dbh_do ( sub { |
165 | my $row = $_[0]->schema->resultset('Artist')->new({}); |
166 | my $rs = $_[0]->schema->resultset('Artist')->search({ |
167 | name => $row, # this is deliberately bogus, see FIXME below! |
168 | }); |
169 | return ($rs, $row); |
170 | }); |
171 | |
a8c2c746 |
172 | is ($pager->next_page, 3, 'There is one more page available'); |
173 | |
174 | # based on 66 per 10 pages |
175 | is ($pager_explicit_count->last_page, 7, 'Correct last page'); |
551e711a |
176 | |
052b8ce2 |
177 | # do some population (invokes some extra codepaths) |
178 | # also exercise the guard code and the manual txn control |
179 | { |
180 | my $guard = $schema->txn_scope_guard; |
181 | # populate with bindvars |
182 | $rs->populate([{ name => 'James Bound' }]); |
183 | $guard->commit; |
184 | |
185 | $schema->txn_begin; |
186 | # populate mixed |
187 | $rs->populate([{ name => 'James Rebound', rank => \ '11' }]); |
188 | $schema->txn_commit; |
189 | |
190 | $schema->txn_begin; |
191 | # and without bindvars |
192 | $rs->populate([{ name => \ '"James Unbound"' }]); |
193 | $schema->txn_rollback; |
194 | } |
195 | |
0a03206a |
196 | # prefetching |
197 | my $cds_rs = $schema->resultset('CD'); |
198 | my $cds_with_artist = $cds_rs->search({}, { prefetch => 'artist' }); |
199 | my $cds_with_tracks = $cds_rs->search({}, { prefetch => 'tracks' }); |
200 | my $cds_with_stuff = $cds_rs->search({}, { prefetch => [ 'genre', { artist => { cds => { tracks => 'cd_single' } } } ] }); |
201 | |
202 | # implicit pref |
203 | my $cds_with_impl_artist = $cds_rs->search({}, { columns => [qw/me.title artist.name/], join => 'artist' }); |
204 | |
205 | # get_column |
206 | my $getcol_rs = $cds_rs->get_column('me.cdid'); |
207 | my $pref_getcol_rs = $cds_with_stuff->get_column('me.cdid'); |
208 | |
209 | # fire the column getters |
210 | my @throwaway = $pref_getcol_rs->all; |
211 | |
a8c2c746 |
212 | my $base_collection = { |
a8c2c746 |
213 | resultset => $rs, |
307ab4c5 |
214 | |
0a03206a |
215 | pref_precursor => $cds_rs, |
216 | |
217 | pref_rs_single => $cds_with_artist, |
218 | pref_rs_multi => $cds_with_tracks, |
219 | pref_rs_nested => $cds_with_stuff, |
220 | |
221 | pref_rs_implicit => $cds_with_impl_artist, |
222 | |
223 | pref_row_single => $cds_with_artist->next, |
224 | pref_row_multi => $cds_with_tracks->next, |
225 | pref_row_nested => $cds_with_stuff->next, |
226 | |
227 | # even though this does not leak Storable croaks on it :((( |
228 | #pref_row_implicit => $cds_with_impl_artist->next, |
229 | |
230 | get_column_rs_plain => $getcol_rs, |
231 | get_column_rs_pref => $pref_getcol_rs, |
232 | |
37aafa2e |
233 | # twice so that we make sure only one H::M object spawned |
234 | chained_resultset => $rs->search_rs ({}, { '+columns' => [ 'foo' ] } ), |
235 | chained_resultset2 => $rs->search_rs ({}, { '+columns' => [ 'bar' ] } ), |
236 | |
a8c2c746 |
237 | row_object => $row_obj, |
551e711a |
238 | |
187ec69a |
239 | mc_row_object => $mc_row_obj, |
240 | |
a8c2c746 |
241 | result_source => $rs->result_source, |
551e711a |
242 | |
4376a157 |
243 | result_source_handle => $rs->result_source->handle, |
244 | |
a8c2c746 |
245 | pager_explicit_count => $pager_explicit_count, |
187ec69a |
246 | |
247 | leaky_resultset => $rs_bind_circref, |
248 | leaky_resultset_cond => $cond_rowobj, |
249 | leaky_resultset_member => $rs_bind_circref->next, |
a8c2c746 |
250 | }; |
574d9b69 |
251 | |
eb7aa960 |
252 | require Storable; |
4376a157 |
253 | %$base_collection = ( |
254 | %$base_collection, |
255 | refrozen => Storable::dclone( $base_collection ), |
256 | rerefrozen => Storable::dclone( Storable::dclone( $base_collection ) ), |
0a03206a |
257 | pref_row_implicit => $cds_with_impl_artist->next, |
4376a157 |
258 | schema => $schema, |
259 | storage => $storage, |
260 | sql_maker => $storage->sql_maker, |
261 | dbh => $storage->_dbh, |
cd122820 |
262 | fresh_pager => $rs->page(5)->pager, |
263 | pager => $pager, |
4376a157 |
264 | ); |
265 | |
6a43bc0c |
266 | if ($has_dt) { |
267 | my $rs = $base_collection->{icdt_rs} = $schema->resultset('Event'); |
268 | |
269 | my $now = DateTime->now; |
270 | for (1..5) { |
271 | $base_collection->{"icdt_row_$_"} = $rs->create({ |
272 | created_on => DateTime->new(year => 2011, month => 1, day => $_, time_zone => "-0${_}00" ), |
273 | starts_at => $now->clone->add(days => $_), |
274 | }); |
275 | } |
276 | |
277 | # re-search |
278 | my @dummy = $rs->all; |
279 | } |
280 | |
eb7aa960 |
281 | # dbh's are created in XS space, so pull them separately |
282 | for ( grep { defined } map { @{$_->{ChildHandles}} } values %{ {DBI->installed_drivers()} } ) { |
283 | $base_collection->{"DBI handle $_"} = $_; |
284 | } |
285 | |
187ec69a |
286 | SKIP: { |
287 | if ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') ) { |
288 | Test::Memory::Cycle::memory_cycle_ok ($base_collection, 'No cycles in the object collection') |
289 | } |
290 | else { |
291 | skip 'Circular ref test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_leaks'), 1; |
292 | } |
eb7aa960 |
293 | } |
574d9b69 |
294 | |
a8c2c746 |
295 | for (keys %$base_collection) { |
296 | $weak_registry->{"basic $_"} = { weakref => $base_collection->{$_} }; |
297 | weaken $weak_registry->{"basic $_"}{weakref}; |
574d9b69 |
298 | } |
551e711a |
299 | } |
300 | |
50261284 |
301 | # check that "phantom-chaining" works - we never lose track of the original $schema |
302 | # and have access to the entire tree without leaking anything |
303 | { |
304 | my $phantom; |
305 | for ( |
306 | sub { DBICTest->init_schema }, |
307 | sub { shift->source('Artist') }, |
308 | sub { shift->resultset }, |
309 | sub { shift->result_source }, |
310 | sub { shift->schema }, |
311 | sub { shift->resultset('Artist') }, |
312 | sub { shift->find_or_create({ name => 'detachable' }) }, |
313 | sub { shift->result_source }, |
314 | sub { shift->schema }, |
315 | sub { shift->clone }, |
187ec69a |
316 | sub { shift->resultset('CD') }, |
317 | sub { shift->next }, |
318 | sub { shift->artist }, |
319 | sub { shift->search_related('cds') }, |
50261284 |
320 | sub { shift->next }, |
187ec69a |
321 | sub { shift->search_related('artist') }, |
50261284 |
322 | sub { shift->result_source }, |
323 | sub { shift->resultset }, |
324 | sub { shift->create({ name => 'detached' }) }, |
325 | sub { shift->update({ name => 'reattached' }) }, |
326 | sub { shift->discard_changes }, |
327 | sub { shift->delete }, |
328 | sub { shift->insert }, |
329 | ) { |
330 | $phantom = $_->($phantom); |
331 | |
332 | my $slot = (sprintf 'phantom %s=%s(0x%x)', # so we don't trigger stringification |
333 | ref $phantom, |
334 | reftype $phantom, |
335 | refaddr $phantom, |
336 | ); |
dee99c24 |
337 | |
50261284 |
338 | $weak_registry->{$slot} = $phantom; |
339 | weaken $weak_registry->{$slot}; |
340 | } |
341 | |
342 | ok( $phantom->in_storage, 'Properly deleted/reinserted' ); |
343 | is( $phantom->name, 'reattached', 'Still correct name' ); |
344 | } |
a8c2c746 |
345 | |
307ab4c5 |
346 | # Naturally we have some exceptions |
347 | my $cleared; |
348 | for my $slot (keys %$weak_registry) { |
6a43bc0c |
349 | if ($slot =~ /^Test::Builder/) { |
c8194884 |
350 | # T::B 2.0 has result objects and other fancyness |
351 | delete $weak_registry->{$slot}; |
352 | } |
6a43bc0c |
353 | elsif ($slot =~ /^SQL::Translator/) { |
307ab4c5 |
354 | # SQLT is a piece of shit, leaks all over |
355 | delete $weak_registry->{$slot}; |
356 | } |
6a43bc0c |
357 | elsif ($slot =~ /^Hash::Merge/) { |
37aafa2e |
358 | # only clear one object of a specific behavior - more would indicate trouble |
307ab4c5 |
359 | delete $weak_registry->{$slot} |
360 | unless $cleared->{hash_merge_singleton}{$weak_registry->{$slot}{weakref}{behavior}}++; |
361 | } |
b4ad8a74 |
362 | elsif (DBIx::Class::_ENV_::INVISIBLE_DOLLAR_AT and $slot =~ /^__TxnScopeGuard__FIXUP__/) { |
48e4eac6 |
363 | delete $weak_registry->{$slot} |
1f870d5a |
364 | } |
eb7aa960 |
365 | elsif ($slot =~ /^DateTime::TimeZone/) { |
366 | # DT is going through a refactor it seems - let it leak zones for now |
367 | delete $weak_registry->{$slot}; |
368 | } |
307ab4c5 |
369 | } |
370 | |
dee99c24 |
371 | # every result class has a result source instance as classdata |
372 | # make sure these are all present and distinct before ignoring |
373 | # (distinct means only 1 reference) |
374 | for my $rs_class ( |
a8c2c746 |
375 | 'DBICTest::BaseResult', |
dee99c24 |
376 | @compose_ns_classes, |
a8c2c746 |
377 | map { DBICTest::Schema->class ($_) } DBICTest::Schema->sources |
dee99c24 |
378 | ) { |
379 | # need to store the SVref and examine it separately, to push the rsrc instance off the pad |
380 | my $SV = svref_2object($rs_class->result_source_instance); |
381 | is( $SV->REFCNT, 1, "Source instance of $rs_class referenced exactly once" ); |
382 | |
383 | # ignore it |
384 | delete $weak_registry->{$rs_class->result_source_instance}; |
fa442fd5 |
385 | } |
a8c2c746 |
386 | |
dee99c24 |
387 | # Schema classes also hold sources, but these are clones, since |
388 | # each source contains the schema (or schema class name in this case) |
389 | # Hence the clone so that the same source can be registered with |
390 | # multiple schemas |
391 | for my $moniker ( keys %{DBICTest::Schema->source_registrations || {}} ) { |
392 | |
393 | my $SV = svref_2object(DBICTest::Schema->source($moniker)); |
394 | is( $SV->REFCNT, 1, "Source instance registered under DBICTest::Schema as $moniker referenced exactly once" ); |
395 | |
396 | delete $weak_registry->{DBICTest::Schema->source($moniker)}; |
fa442fd5 |
397 | } |
a8c2c746 |
398 | |
187ec69a |
399 | # FIXME !!! |
400 | # There is an actual strong circular reference taking place here, but because |
401 | # half of it is in XS no leaktracer sees it, and Devel::FindRef is equally |
402 | # stumped when trying to trace the origin. The problem is: |
403 | # |
404 | # $cond_object --> result_source --> schema --> storage --> $dbh --> {cached_kids} |
405 | # ^ / |
406 | # \-------- bound value on prepared/cached STH <-----------/ |
407 | # |
408 | TODO: { |
409 | local $TODO = 'Not sure how to fix this yet, an entanglment could be an option'; |
410 | my $r = $weak_registry->{'basic leaky_resultset_cond'}{weakref}; |
411 | ok(! defined $r, 'We no longer leak!') |
412 | or $r->result_source(undef); |
413 | } |
414 | |
48e4eac6 |
415 | for my $slot (sort keys %$weak_registry) { |
a8c2c746 |
416 | |
417 | ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do { |
418 | my $diag = ''; |
419 | |
420 | $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n" |
66917da3 |
421 | if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); |
a8c2c746 |
422 | |
423 | if (my $stack = $weak_registry->{$slot}{strace}) { |
424 | $diag .= " Reference first seen$stack"; |
425 | } |
426 | |
427 | diag $diag if $diag; |
428 | }; |
551e711a |
429 | } |
430 | |
66917da3 |
431 | # we got so far without a failure - this is a good thing |
432 | # now let's try to rerun this script under a "persistent" environment |
433 | # this is ugly and dirty but we do not yet have a Test::Embedded or |
434 | # similar |
435 | |
436 | my @pperl_cmd = (qw/pperl --prefork=1/, __FILE__); |
437 | my @pperl_term_cmd = @pperl_cmd; |
438 | splice @pperl_term_cmd, 1, 0, '--kill'; |
439 | |
440 | # scgi is smart and will auto-reap after -t amount of seconds |
441 | my @scgi_cmd = (qw/speedy -- -t5/, __FILE__); |
442 | |
443 | SKIP: { |
444 | skip 'Test already in a persistent loop', 1 |
445 | if $ENV{DBICTEST_IN_PERSISTENT_ENV}; |
446 | |
447 | skip 'Persistence test disabled on regular installs', 1 |
448 | if DBICTest::RunMode->is_plain; |
449 | |
450 | skip 'Main test failed - skipping persistent env tests', 1 |
451 | unless $TB->is_passing; |
452 | |
453 | # set up -I |
454 | require Config; |
455 | local $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC); |
456 | |
457 | local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1; |
458 | |
459 | # try with pperl |
460 | SKIP: { |
461 | skip 'PPerl persistent environment tests require PPerl', 1 |
462 | unless eval { require PPerl }; |
463 | |
464 | # since PPerl is racy and sucks - just prime the "server" |
465 | { |
466 | local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1; |
467 | system(@pperl_cmd); |
468 | sleep 1; |
469 | |
470 | # see if it actually runs - if not might as well bail now |
471 | skip "Something is wrong with pperl ($!)", 1 |
472 | if system(@pperl_cmd); |
473 | } |
474 | |
475 | for (1,2,3) { |
476 | system(@pperl_cmd); |
477 | ok (!$?, "Run in persistent env (PPerl pass $_): exit $?"); |
478 | } |
479 | |
480 | ok (! system (@pperl_term_cmd), 'killed pperl instance'); |
481 | } |
482 | |
483 | # try with speedy-cgi |
484 | SKIP: { |
485 | skip 'SPeedyCGI persistent environment tests require CGI::SpeedyCGI', 1 |
486 | unless eval { require CGI::SpeedyCGI }; |
487 | |
488 | { |
489 | local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1; |
490 | skip "Something is wrong with speedy ($!)", 1 |
491 | if system(@scgi_cmd); |
492 | sleep 1; |
493 | } |
494 | |
495 | for (1,2,3) { |
496 | system(@scgi_cmd); |
497 | ok (!$?, "Run in persistent env (SpeedyCGI pass $_): exit $?"); |
498 | } |
499 | } |
500 | } |
501 | |
551e711a |
502 | done_testing; |
66917da3 |
503 | |
504 | # just an extra precaution in case we blew away from the SKIP - since there are no |
505 | # PID files to go by (man does pperl really suck :( |
506 | END { |
507 | unless ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { |
508 | close STDOUT; |
509 | close STDERR; |
510 | local $?; # otherwise test will inherit $? of the system() |
511 | system (@pperl_term_cmd); |
512 | } |
513 | } |