Commit | Line | Data |
c0329273 |
1 | BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } |
2 | |
66917da3 |
3 | # work around brain damage in PPerl (yes, it has to be a global) |
4 | $SIG{__WARN__} = sub { |
5 | warn @_ unless $_[0] =~ /\QUse of "goto" to jump into a construct is deprecated/ |
6 | } if ($ENV{DBICTEST_IN_PERSISTENT_ENV}); |
7 | |
8 | # the persistent environments run with this flag first to see if |
9 | # we will run at all (e.g. it will fail if $^X doesn't match) |
10 | exit 0 if $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY}; |
11 | |
f05edfd1 |
12 | # Do the override as early as possible so that CORE::bless doesn't get compiled away |
13 | # We will replace $bless_override only if we are in author mode |
14 | my $bless_override; |
15 | BEGIN { |
16 | $bless_override = sub { |
17 | CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ); |
18 | }; |
19 | *CORE::GLOBAL::bless = sub { goto $bless_override }; |
20 | } |
21 | |
50261284 |
22 | use strict; |
23 | use warnings; |
a917fb06 |
24 | use Test::More; |
d5e5fb4b |
25 | |
08a8d8f1 |
26 | BEGIN { |
27 | require DBICTest::Util; |
28 | plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test" |
29 | if DBICTest::Util::PEEPEENESS(); |
30 | } |
c0329273 |
31 | |
30c81ba9 |
32 | use DBICTest::RunMode; |
ee20935b |
33 | use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs); |
34 | use Scalar::Util qw(weaken blessed reftype); |
35 | use DBIx::Class::_Util qw(hrefaddr sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt); |
18a2903b |
36 | use DBIx::Class::Optional::Dependencies; |
30c81ba9 |
37 | |
66917da3 |
38 | my $TB = Test::More->builder; |
39 | if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { |
ee20935b |
40 | # without this explicit close TB warns in END after a ->reset |
41 | close ($TB->$_) for qw(output failure_output todo_output); |
66917da3 |
42 | |
ee20935b |
43 | # newer TB does not auto-reopen handles |
44 | if ( modver_gt_or_eq( 'Test::More', '1.200' ) ) { |
45 | open ($TB->$_, '>&', *STDERR) |
46 | for qw( failure_output todo_output ); |
7be5717e |
47 | open ($TB->output, '>&', *STDOUT); |
48 | } |
49 | |
50 | # so done_testing can work on every persistent pass |
51 | $TB->reset; |
66917da3 |
52 | } |
53 | |
a8c2c746 |
54 | # this is what holds all weakened refs to be checked for leakage |
55 | my $weak_registry = {}; |
56 | |
6a43bc0c |
57 | # whether or to invoke IC::DT |
58 | my $has_dt; |
59 | |
a8c2c746 |
60 | # Skip the heavy-duty leak tracing when just doing an install |
8b60b921 |
61 | # or when having Moose crap all over everything |
de0edd06 |
62 | # FIXME - remove when Replicated gets off Moose |
8b60b921 |
63 | if ( !$ENV{DBICTEST_VIA_REPLICATED} and !DBICTest::RunMode->is_plain ) { |
f05edfd1 |
64 | |
eb7aa960 |
65 | # redefine the bless override so that we can catch each and every object created |
a8c2c746 |
66 | no warnings qw/redefine once/; |
67 | no strict qw/refs/; |
68 | |
f05edfd1 |
69 | $bless_override = sub { |
70 | |
a8c2c746 |
71 | my $obj = CORE::bless( |
72 | $_[0], (@_ > 1) ? $_[1] : do { |
73 | my ($class, $fn, $line) = caller(); |
74 | fail ("bless() of $_[0] into $class without explicit class specification at $fn line $line") |
75 | if $class =~ /^ (?: DBIx\:\:Class | DBICTest ) /x; |
76 | $class; |
77 | } |
78 | ); |
79 | |
8d6b1478 |
80 | # unicode is tricky, and now we happen to invoke it early via a |
81 | # regex in connection() |
82 | return $obj if (ref $obj) =~ /^utf8/; |
83 | |
7be5717e |
84 | # Test Builder is now making a new object for every pass/fail (que bloat?) |
85 | # and as such we can't really store any of its objects (since it will |
86 | # re-populate the registry while checking it, ewwww!) |
ee20935b |
87 | return $obj if (ref $obj) =~ /^TB2::|^Test::Stream/; |
7be5717e |
88 | |
5dc4301c |
89 | # populate immediately to avoid weird side effects |
65d35121 |
90 | return populate_weakregistry ($weak_registry, $obj ); |
a8c2c746 |
91 | }; |
92 | |
e2741c7f |
93 | |
94 | for my $func (qw( dbic_internal_try dbic_internal_catch )) { |
95 | my $orig = \&{"DBIx::Class::_Util::$func"}; |
96 | *{"DBIx::Class::_Util"} = sub (&;@) { |
65d35121 |
97 | populate_weakregistry( $weak_registry, $_[0] ); |
a8c2c746 |
98 | goto $orig; |
99 | } |
100 | } |
eb7aa960 |
101 | |
e2741c7f |
102 | if ( eval { require Try::Tiny } ) { |
103 | for my $func (qw( try catch finally )) { |
104 | my $orig = \&{"Try::Tiny::$func"}; |
105 | *{"Try::Tiny::$func"} = sub (&;@) { |
106 | populate_weakregistry( $weak_registry, $_[0] ); |
107 | goto $orig; |
108 | } |
109 | } |
110 | } |
111 | |
112 | |
eb7aa960 |
113 | # Some modules are known to install singletons on-load |
114 | # Load them and empty the registry |
115 | |
116 | # this loads the DT armada |
54a9a088 |
117 | $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for([qw( test_rdbms_sqlite ic_dt )]); |
eb7aa960 |
118 | |
eb7aa960 |
119 | require DBI; |
120 | require DBD::SQLite; |
e6ff3658 |
121 | require Moo; |
296248c3 |
122 | require Math::BigInt; |
eb7aa960 |
123 | |
124 | %$weak_registry = (); |
a8c2c746 |
125 | } |
126 | |
127 | { |
66917da3 |
128 | use_ok ('DBICTest'); |
a917fb06 |
129 | |
a8c2c746 |
130 | my $schema = DBICTest->init_schema; |
131 | my $rs = $schema->resultset ('Artist'); |
132 | my $storage = $schema->storage; |
a917fb06 |
133 | |
052b8ce2 |
134 | my $row_obj = $rs->search({}, { rows => 1})->next; # so that commits/rollbacks work |
a8c2c746 |
135 | ok ($row_obj, 'row from db'); |
136 | |
052b8ce2 |
137 | # txn_do to invoke more codepaths |
a8c2c746 |
138 | my ($mc_row_obj, $pager, $pager_explicit_count) = $schema->txn_do (sub { |
139 | |
9345b14c |
140 | my $artist = $schema->resultset('Artist')->create ({ |
a8c2c746 |
141 | name => 'foo artist', |
142 | cds => [{ |
143 | title => 'foo cd', |
144 | year => 1984, |
187ec69a |
145 | tracks => [ |
146 | { title => 't1' }, |
147 | { title => 't2' }, |
148 | ], |
149 | genre => { name => 'mauve' }, |
a8c2c746 |
150 | }], |
151 | }); |
152 | |
153 | my $pg = $rs->search({}, { rows => 1})->page(2)->pager; |
154 | |
155 | my $pg_wcount = $rs->page(4)->pager->total_entries (66); |
156 | |
157 | return ($artist, $pg, $pg_wcount); |
158 | }); |
159 | |
9345b14c |
160 | # more codepaths - error handling in txn_do |
161 | { |
162 | eval { $schema->txn_do ( sub { |
163 | $storage->_dbh->begin_work; |
164 | fail ('how did we get so far?!'); |
165 | } ) }; |
166 | |
167 | eval { $schema->txn_do ( sub { |
168 | $schema->txn_do ( sub { |
169 | die "It's called EXCEPTION"; |
170 | fail ('how did we get so far?!'); |
171 | } ); |
172 | fail ('how did we get so far?!'); |
173 | } ) }; |
174 | like( $@, qr/It\'s called EXCEPTION/, 'Exception correctly propagated in nested txn_do' ); |
175 | } |
176 | |
177 | # dbh_do codepath |
187ec69a |
178 | my ($rs_bind_circref, $cond_rowobj) = $schema->storage->dbh_do ( sub { |
179 | my $row = $_[0]->schema->resultset('Artist')->new({}); |
180 | my $rs = $_[0]->schema->resultset('Artist')->search({ |
181 | name => $row, # this is deliberately bogus, see FIXME below! |
182 | }); |
183 | return ($rs, $row); |
184 | }); |
185 | |
a8c2c746 |
186 | is ($pager->next_page, 3, 'There is one more page available'); |
187 | |
188 | # based on 66 per 10 pages |
189 | is ($pager_explicit_count->last_page, 7, 'Correct last page'); |
551e711a |
190 | |
052b8ce2 |
191 | # do some population (invokes some extra codepaths) |
192 | # also exercise the guard code and the manual txn control |
193 | { |
194 | my $guard = $schema->txn_scope_guard; |
195 | # populate with bindvars |
196 | $rs->populate([{ name => 'James Bound' }]); |
197 | $guard->commit; |
198 | |
199 | $schema->txn_begin; |
200 | # populate mixed |
201 | $rs->populate([{ name => 'James Rebound', rank => \ '11' }]); |
202 | $schema->txn_commit; |
203 | |
204 | $schema->txn_begin; |
205 | # and without bindvars |
206 | $rs->populate([{ name => \ '"James Unbound"' }]); |
207 | $schema->txn_rollback; |
208 | } |
209 | |
0a03206a |
210 | # prefetching |
211 | my $cds_rs = $schema->resultset('CD'); |
212 | my $cds_with_artist = $cds_rs->search({}, { prefetch => 'artist' }); |
213 | my $cds_with_tracks = $cds_rs->search({}, { prefetch => 'tracks' }); |
214 | my $cds_with_stuff = $cds_rs->search({}, { prefetch => [ 'genre', { artist => { cds => { tracks => 'cd_single' } } } ] }); |
215 | |
216 | # implicit pref |
217 | my $cds_with_impl_artist = $cds_rs->search({}, { columns => [qw/me.title artist.name/], join => 'artist' }); |
218 | |
219 | # get_column |
220 | my $getcol_rs = $cds_rs->get_column('me.cdid'); |
221 | my $pref_getcol_rs = $cds_with_stuff->get_column('me.cdid'); |
222 | |
a8c2c746 |
223 | my $base_collection = { |
a8c2c746 |
224 | resultset => $rs, |
307ab4c5 |
225 | |
0a03206a |
226 | pref_precursor => $cds_rs, |
227 | |
228 | pref_rs_single => $cds_with_artist, |
229 | pref_rs_multi => $cds_with_tracks, |
230 | pref_rs_nested => $cds_with_stuff, |
231 | |
232 | pref_rs_implicit => $cds_with_impl_artist, |
233 | |
234 | pref_row_single => $cds_with_artist->next, |
235 | pref_row_multi => $cds_with_tracks->next, |
236 | pref_row_nested => $cds_with_stuff->next, |
237 | |
238 | # even though this does not leak Storable croaks on it :((( |
239 | #pref_row_implicit => $cds_with_impl_artist->next, |
240 | |
241 | get_column_rs_plain => $getcol_rs, |
242 | get_column_rs_pref => $pref_getcol_rs, |
243 | |
37aafa2e |
244 | # twice so that we make sure only one H::M object spawned |
b35500f1 |
245 | chained_resultset => $rs->search_rs ({}, { '+columns' => { foo => 'artistid' } } ), |
246 | chained_resultset2 => $rs->search_rs ({}, { '+columns' => { bar => 'artistid' } } ), |
37aafa2e |
247 | |
a8c2c746 |
248 | row_object => $row_obj, |
551e711a |
249 | |
187ec69a |
250 | mc_row_object => $mc_row_obj, |
251 | |
a8c2c746 |
252 | result_source => $rs->result_source, |
551e711a |
253 | |
4376a157 |
254 | result_source_handle => $rs->result_source->handle, |
255 | |
a8c2c746 |
256 | pager_explicit_count => $pager_explicit_count, |
187ec69a |
257 | |
258 | leaky_resultset => $rs_bind_circref, |
259 | leaky_resultset_cond => $cond_rowobj, |
a8c2c746 |
260 | }; |
574d9b69 |
261 | |
6ae62c5c |
262 | # fire all resultsets multiple times, once here, more below |
263 | # some of these can't find anything (notably leaky_resultset) |
264 | my @rsets = grep { |
265 | blessed $_ |
266 | and |
267 | ( |
268 | $_->isa('DBIx::Class::ResultSet') |
269 | or |
270 | $_->isa('DBIx::Class::ResultSetColumn') |
271 | ) |
272 | } values %$base_collection; |
273 | |
274 | |
275 | my $fire_resultsets = sub { |
276 | local $ENV{DBIC_COLUMNS_INCLUDE_FILTER_RELS} = 1; |
277 | local $SIG{__WARN__} = sigwarn_silencer( |
278 | qr/Unable to deflate 'filter'-type relationship 'artist'.+related object primary key not retrieved/ |
279 | ); |
280 | |
281 | map |
282 | { $_, (blessed($_) ? { $_->get_columns } : ()) } |
283 | map |
284 | { $_->all } |
285 | @rsets |
286 | ; |
287 | }; |
b35500f1 |
288 | |
6ae62c5c |
289 | push @{$base_collection->{random_results}}, $fire_resultsets->(); |
b35500f1 |
290 | |
291 | # FIXME - something throws a Storable for a spin if we keep |
292 | # the results in-collection. The same problem is seen above, |
293 | # swept under the rug back in 0a03206a, damned lazy ribantainer |
294 | { |
295 | local $base_collection->{random_results}; |
218b7c12 |
296 | |
eb7aa960 |
297 | require Storable; |
4376a157 |
298 | %$base_collection = ( |
299 | %$base_collection, |
300 | refrozen => Storable::dclone( $base_collection ), |
301 | rerefrozen => Storable::dclone( Storable::dclone( $base_collection ) ), |
0a03206a |
302 | pref_row_implicit => $cds_with_impl_artist->next, |
4376a157 |
303 | schema => $schema, |
304 | storage => $storage, |
305 | sql_maker => $storage->sql_maker, |
306 | dbh => $storage->_dbh, |
cd122820 |
307 | fresh_pager => $rs->page(5)->pager, |
308 | pager => $pager, |
4376a157 |
309 | ); |
b35500f1 |
310 | } |
4376a157 |
311 | |
21aa86aa |
312 | # FIXME - ideally this kind of collector ought to be global, but attempts |
313 | # with an invasive debugger-based tracer did not quite work out... yet |
314 | # Manually scan the innards of everything we have in the base collection |
315 | # we assembled so far (skip the DT madness below) *recursively* |
316 | # |
317 | # Only do this when we do have the bits to look inside CVs properly, |
318 | # without it we are liable to pick up object defaults that are locked |
319 | # in method closures |
320 | if (DBICTest::Util::LeakTracer::CV_TRACING) { |
321 | visit_refs( |
322 | refs => [ $base_collection ], |
323 | action => sub { |
324 | populate_weakregistry ($weak_registry, $_[0]); |
325 | 1; # true means "keep descending" |
326 | }, |
327 | ); |
6ae62c5c |
328 | |
329 | # do a heavy-duty fire-and-compare loop on all resultsets |
330 | # this is expensive - not running on install |
331 | my $typecounts = {}; |
014846ee |
332 | if ( |
333 | ! DBICTest::RunMode->is_plain |
334 | and |
335 | ! $ENV{DBICTEST_IN_PERSISTENT_ENV} |
014846ee |
336 | ) { |
6ae62c5c |
337 | |
338 | # FIXME - ideally we should be able to just populate an alternative |
339 | # registry, subtract everything from the main one, and arrive at |
340 | # an "empty" resulting hash |
341 | # However due to gross inefficiencies in the ::ResultSet code we |
342 | # end up recalculating a new set of aliasmaps which could have very |
343 | # well been cached if it wasn't for... anyhow |
344 | # What we do here for the time being is similar to the lazy approach |
345 | # of Devel::LeakTrace - we just make sure we do not end up with more |
346 | # reftypes than when we started. At least we are not blanket-counting |
347 | # SVs like D::LT does, but going by reftype... sigh... |
348 | |
349 | for (values %$weak_registry) { |
350 | if ( my $r = reftype($_->{weakref}) ) { |
351 | $typecounts->{$r}--; |
352 | } |
353 | } |
354 | |
355 | # For now we can only reuse the same registry, see FIXME above/below |
356 | #for my $interim_wr ({}, {}) { |
357 | for my $interim_wr ( ($weak_registry) x 4 ) { |
358 | |
359 | visit_refs( |
360 | refs => [ $fire_resultsets->(), @rsets ], |
361 | action => sub { |
362 | populate_weakregistry ($interim_wr, $_[0]); |
363 | 1; # true means "keep descending" |
364 | }, |
365 | ); |
366 | |
367 | # FIXME - this is what *should* be here |
368 | # |
369 | ## anything we have seen so far is cool |
370 | #delete @{$interim_wr}{keys %$weak_registry}; |
371 | # |
6ae62c5c |
372 | ## moment of truth - the rest ought to be gone |
373 | #assert_empty_weakregistry($interim_wr); |
374 | } |
375 | |
376 | for (values %$weak_registry) { |
377 | if ( my $r = reftype($_->{weakref}) ) { |
378 | $typecounts->{$r}++; |
379 | } |
380 | } |
381 | } |
382 | |
383 | for (keys %$typecounts) { |
384 | fail ("Amount of $_ refs changed by $typecounts->{$_} during resultset mass-execution") |
385 | if ( abs ($typecounts->{$_}) > 1 ); # there is a pad caught somewhere, the +1/-1 can be ignored |
386 | } |
21aa86aa |
387 | } |
388 | |
6a43bc0c |
389 | if ($has_dt) { |
390 | my $rs = $base_collection->{icdt_rs} = $schema->resultset('Event'); |
391 | |
392 | my $now = DateTime->now; |
393 | for (1..5) { |
394 | $base_collection->{"icdt_row_$_"} = $rs->create({ |
395 | created_on => DateTime->new(year => 2011, month => 1, day => $_, time_zone => "-0${_}00" ), |
396 | starts_at => $now->clone->add(days => $_), |
397 | }); |
398 | } |
399 | |
400 | # re-search |
401 | my @dummy = $rs->all; |
402 | } |
403 | |
eb7aa960 |
404 | # dbh's are created in XS space, so pull them separately |
405 | for ( grep { defined } map { @{$_->{ChildHandles}} } values %{ {DBI->installed_drivers()} } ) { |
406 | $base_collection->{"DBI handle $_"} = $_; |
407 | } |
408 | |
65d35121 |
409 | populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_") |
410 | for keys %$base_collection; |
551e711a |
411 | } |
412 | |
50261284 |
413 | # check that "phantom-chaining" works - we never lose track of the original $schema |
414 | # and have access to the entire tree without leaking anything |
415 | { |
416 | my $phantom; |
417 | for ( |
39b80a73 |
418 | sub { DBICTest->init_schema( sqlite_use_file => 0 ) }, |
50261284 |
419 | sub { shift->source('Artist') }, |
420 | sub { shift->resultset }, |
421 | sub { shift->result_source }, |
422 | sub { shift->schema }, |
423 | sub { shift->resultset('Artist') }, |
424 | sub { shift->find_or_create({ name => 'detachable' }) }, |
425 | sub { shift->result_source }, |
426 | sub { shift->schema }, |
427 | sub { shift->clone }, |
187ec69a |
428 | sub { shift->resultset('CD') }, |
429 | sub { shift->next }, |
430 | sub { shift->artist }, |
431 | sub { shift->search_related('cds') }, |
50261284 |
432 | sub { shift->next }, |
187ec69a |
433 | sub { shift->search_related('artist') }, |
50261284 |
434 | sub { shift->result_source }, |
435 | sub { shift->resultset }, |
436 | sub { shift->create({ name => 'detached' }) }, |
437 | sub { shift->update({ name => 'reattached' }) }, |
438 | sub { shift->discard_changes }, |
439 | sub { shift->delete }, |
440 | sub { shift->insert }, |
441 | ) { |
65d35121 |
442 | $phantom = populate_weakregistry ( $weak_registry, scalar $_->($phantom) ); |
50261284 |
443 | } |
444 | |
445 | ok( $phantom->in_storage, 'Properly deleted/reinserted' ); |
446 | is( $phantom->name, 'reattached', 'Still correct name' ); |
447 | } |
a8c2c746 |
448 | |
307ab4c5 |
449 | # Naturally we have some exceptions |
450 | my $cleared; |
96577657 |
451 | for my $addr (keys %$weak_registry) { |
452 | my $names = join "\n", keys %{$weak_registry->{$addr}{slot_names}}; |
453 | |
454 | if ($names =~ /^Test::Builder/m) { |
c8194884 |
455 | # T::B 2.0 has result objects and other fancyness |
96577657 |
456 | delete $weak_registry->{$addr}; |
c8194884 |
457 | } |
e48635f7 |
458 | # remove this when IO::Dir is gone from SQLT |
459 | elsif ($INC{"IO/Dir.pm"} and $names =~ /^Class::Struct::Tie_ISA/m) { |
439a7283 |
460 | delete $weak_registry->{$addr}; |
461 | } |
96577657 |
462 | elsif ($names =~ /^Hash::Merge/m) { |
37aafa2e |
463 | # only clear one object of a specific behavior - more would indicate trouble |
96577657 |
464 | delete $weak_registry->{$addr} |
465 | unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++; |
307ab4c5 |
466 | } |
e9d552de |
467 | elsif ($names =~ /^B::Hooks::EndOfScope::PP::_TieHintHashFieldHash/m) { |
468 | # there is one tied lexical which stays alive until GC time |
469 | # https://metacpan.org/source/ETHER/B-Hooks-EndOfScope-0.15/lib/B/Hooks/EndOfScope/PP/FieldHash.pm#L24 |
470 | # simply ignore it here, instead of teaching the leaktracer to examine ties |
471 | # the latter is possible yet terrible: https://github.com/dbsrgits/dbix-class/blob/v0.082820/t/lib/DBICTest/Util/LeakTracer.pm#L113-L117 |
472 | delete $weak_registry->{$addr} |
473 | unless $cleared->{bheos_pptiehinthashfieldhash}++; |
474 | } |
d6c13bfd |
475 | elsif ( |
476 | $names =~ /^Data::Dumper/m |
477 | and |
478 | $weak_registry->{$addr}{stacktrace} =~ /\bDBIx::Class::SQLMaker::Util::lax_serialize\b/ |
479 | ) { |
480 | # only clear one object of a specific behavior - more would indicate trouble |
481 | delete $weak_registry->{$addr} |
482 | unless $cleared->{dd_lax_serializer}++; |
483 | } |
3619783b |
484 | elsif ($names =~ /^DateTime::TimeZone::UTC/m) { |
485 | # DT is going through a refactor it seems - let it leak zones for now |
486 | delete $weak_registry->{$addr}; |
487 | } |
c0fe9332 |
488 | elsif ( |
75c23ff0 |
489 | # # if we can look at closed over pieces - we will register it as a global |
490 | # !DBICTest::Util::LeakTracer::CV_TRACING |
491 | # and |
c0fe9332 |
492 | $names =~ /^SQL::Translator::Generator::DDL::SQLite/m |
493 | ) { |
494 | # SQLT::Producer::SQLite keeps global generators around for quoted |
495 | # and non-quoted DDL, allow one for each quoting style |
496 | delete $weak_registry->{$addr} |
497 | unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$addr}{weakref}->quote_chars}}++; |
498 | } |
307ab4c5 |
499 | } |
500 | |
187ec69a |
501 | # FIXME !!! |
502 | # There is an actual strong circular reference taking place here, but because |
5dc4301c |
503 | # half of it is in XS, so it is a bit harder to track down (it stumps D::FR) |
504 | # (our tracker does not yet do it, but it'd be nice) |
505 | # The problem is: |
187ec69a |
506 | # |
728f32b5 |
507 | # $cond_object --> result_source --> schema --> storage --> $dbh --> {CachedKids} |
187ec69a |
508 | # ^ / |
509 | # \-------- bound value on prepared/cached STH <-----------/ |
510 | # |
728f32b5 |
511 | { |
5dc4301c |
512 | my @circreffed; |
513 | |
514 | for my $r (map |
515 | { $_->{weakref} } |
516 | grep |
517 | { $_->{slot_names}{'basic leaky_resultset_cond'} } |
518 | values %$weak_registry |
519 | ) { |
520 | local $TODO = 'Needs Data::Entangled or somesuch - see RT#82942'; |
728f32b5 |
521 | ok(! defined $r, 'Self-referential RS conditions no longer leak!') |
5dc4301c |
522 | or push @circreffed, $r; |
523 | } |
524 | |
525 | if (@circreffed) { |
526 | is (scalar @circreffed, 1, 'One resultset expected to leak'); |
527 | |
528 | # this is useless on its own, it is to showcase the circref-diag |
529 | # and eventually test it when it is operational |
530 | local $TODO = 'Needs Data::Entangled or somesuch - see RT#82942'; |
531 | while (@circreffed) { |
532 | weaken (my $r = shift @circreffed); |
533 | |
534 | populate_weakregistry( (my $mini_registry = {}), $r ); |
535 | assert_empty_weakregistry( $mini_registry ); |
536 | |
537 | $r->result_source(undef); |
538 | } |
728f32b5 |
539 | } |
187ec69a |
540 | } |
541 | |
65d35121 |
542 | assert_empty_weakregistry ($weak_registry); |
551e711a |
543 | |
66917da3 |
544 | # we got so far without a failure - this is a good thing |
545 | # now let's try to rerun this script under a "persistent" environment |
546 | # this is ugly and dirty but we do not yet have a Test::Embedded or |
547 | # similar |
548 | |
7617dcc4 |
549 | my $persistence_tests; |
66917da3 |
550 | SKIP: { |
551 | skip 'Test already in a persistent loop', 1 |
552 | if $ENV{DBICTEST_IN_PERSISTENT_ENV}; |
553 | |
66917da3 |
554 | skip 'Main test failed - skipping persistent env tests', 1 |
555 | unless $TB->is_passing; |
556 | |
ee20935b |
557 | skip "Test::Builder\@@{[ Test::Builder->VERSION ]} known to break persistence tests", 1 |
558 | if modver_gt_or_eq_and_lt( 'Test::More', '1.200', '1.301001_099' ); |
559 | |
66917da3 |
560 | local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1; |
26710bc9 |
561 | local $ENV{DBICTEST_ANFANG_DEFANG} = 1; |
66917da3 |
562 | |
aff5e9c1 |
563 | require File::Spec; |
564 | |
7617dcc4 |
565 | $persistence_tests = { |
566 | PPerl => { |
567 | cmd => [qw/pperl --prefork=1/, __FILE__], |
568 | }, |
569 | 'CGI::SpeedyCGI' => { |
570 | cmd => [qw/speedy -- -t5/, __FILE__], |
571 | }, |
572 | }; |
573 | |
574 | # scgi is smart and will auto-reap after -t amount of seconds |
575 | # pperl needs an actual killer :( |
576 | $persistence_tests->{PPerl}{termcmd} = [ |
577 | $persistence_tests->{PPerl}{cmd}[0], |
578 | '--kill', |
579 | @{$persistence_tests->{PPerl}{cmd}}[ 1 .. $#{$persistence_tests->{PPerl}{cmd}} ], |
580 | ]; |
581 | |
4fb8d74c |
582 | # set up -I |
583 | require Config; |
584 | $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC); |
585 | |
586 | # adjust PATH for -T |
587 | if (length $ENV{PATH}) { |
588 | ( $ENV{PATH} ) = join ( $Config::Config{path_sep}, |
589 | map { length($_) ? File::Spec->rel2abs($_) : () } |
590 | split /\Q$Config::Config{path_sep}/, $ENV{PATH} |
591 | ) =~ /\A(.+)\z/; |
592 | } |
7be5717e |
593 | |
594 | for my $type (keys %$persistence_tests) { SKIP: { |
53a5200d |
595 | unless (eval "require $type") { |
596 | # Don't terminate what we didn't start |
597 | delete $persistence_tests->{$type}{termcmd}; |
598 | skip "$type module not found", 1; |
599 | } |
7be5717e |
600 | |
601 | my @cmd = @{$persistence_tests->{$type}{cmd}}; |
66917da3 |
602 | |
603 | # since PPerl is racy and sucks - just prime the "server" |
604 | { |
605 | local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1; |
7be5717e |
606 | system(@cmd); |
66917da3 |
607 | sleep 1; |
608 | |
7be5717e |
609 | # see if the thing actually runs, if not - might as well bail now |
610 | skip "Something is wrong with $type ($!)", 1 |
611 | if system(@cmd); |
66917da3 |
612 | } |
613 | |
4fb8d74c |
614 | require IPC::Open2; |
615 | |
66917da3 |
616 | for (1,2,3) { |
7be5717e |
617 | note ("Starting run in persistent env ($type pass $_)"); |
618 | IPC::Open2::open2(my $out, undef, @cmd); |
619 | my @out_lines; |
620 | while (my $ln = <$out>) { |
621 | next if $ln =~ /^\s*$/; |
622 | push @out_lines, " $ln"; |
623 | last if $ln =~ /^\d+\.\.\d+$/; # this is persistence, we need to terminate reading on our end |
624 | } |
625 | print $_ for @out_lines; |
626 | close $out; |
627 | wait; |
628 | ok (!$?, "Run in persistent env ($type pass $_): exit $?"); |
629 | ok (scalar @out_lines, "Run in persistent env ($type pass $_): got output"); |
66917da3 |
630 | } |
631 | |
7be5717e |
632 | ok (! system (@{$persistence_tests->{$type}{termcmd}}), "killed $type server instance") |
633 | if $persistence_tests->{$type}{termcmd}; |
634 | }} |
66917da3 |
635 | } |
636 | |
551e711a |
637 | done_testing; |
66917da3 |
638 | |
639 | # just an extra precaution in case we blew away from the SKIP - since there are no |
640 | # PID files to go by (man does pperl really suck :( |
641 | END { |
7617dcc4 |
642 | if ($persistence_tests->{PPerl}{termcmd}) { |
66917da3 |
643 | local $?; # otherwise test will inherit $? of the system() |
7617dcc4 |
644 | require IPC::Open3; |
645 | open my $null, ">", File::Spec->devnull; |
646 | waitpid( |
647 | IPC::Open3::open3(undef, $null, $null, @{$persistence_tests->{PPerl}{termcmd}}), |
648 | 0, |
649 | ); |
66917da3 |
650 | } |
651 | } |