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}) { |
7be5717e |
26 | # without this explicit close older TBs warn in END after a ->reset |
27 | if ($TB->VERSION < 1.005) { |
28 | close ($TB->$_) for (qw/output failure_output todo_output/); |
29 | } |
66917da3 |
30 | |
7be5717e |
31 | # if I do not do this, I get happy sigpipes on new TB, no idea why |
32 | # (the above close-and-forget doesn't work - new TB does *not* reopen |
33 | # its handles automatically anymore) |
34 | else { |
35 | for (qw/failure_output todo_output/) { |
36 | close $TB->$_; |
37 | open ($TB->$_, '>&', *STDERR); |
38 | } |
66917da3 |
39 | |
7be5717e |
40 | close $TB->output; |
41 | open ($TB->output, '>&', *STDOUT); |
42 | } |
43 | |
44 | # so done_testing can work on every persistent pass |
45 | $TB->reset; |
66917da3 |
46 | } |
47 | |
d5e5fb4b |
48 | use lib qw(t/lib); |
49 | use DBICTest::RunMode; |
218b7c12 |
50 | use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; |
e0b2dc74 |
51 | use DBIx::Class; |
d12d8272 |
52 | BEGIN { |
d5e5fb4b |
53 | plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test" |
dee99c24 |
54 | if DBIx::Class::_ENV_::PEEPEENESS; |
d12d8272 |
55 | } |
56 | |
a8c2c746 |
57 | # this is what holds all weakened refs to be checked for leakage |
58 | my $weak_registry = {}; |
59 | |
6a43bc0c |
60 | # whether or to invoke IC::DT |
61 | my $has_dt; |
62 | |
a8c2c746 |
63 | # Skip the heavy-duty leak tracing when just doing an install |
64 | unless (DBICTest::RunMode->is_plain) { |
f05edfd1 |
65 | |
eb7aa960 |
66 | # redefine the bless override so that we can catch each and every object created |
a8c2c746 |
67 | no warnings qw/redefine once/; |
68 | no strict qw/refs/; |
69 | |
f05edfd1 |
70 | $bless_override = sub { |
71 | |
a8c2c746 |
72 | my $obj = CORE::bless( |
73 | $_[0], (@_ > 1) ? $_[1] : do { |
74 | my ($class, $fn, $line) = caller(); |
75 | fail ("bless() of $_[0] into $class without explicit class specification at $fn line $line") |
76 | if $class =~ /^ (?: DBIx\:\:Class | DBICTest ) /x; |
77 | $class; |
78 | } |
79 | ); |
80 | |
8d6b1478 |
81 | # unicode is tricky, and now we happen to invoke it early via a |
82 | # regex in connection() |
83 | return $obj if (ref $obj) =~ /^utf8/; |
84 | |
7be5717e |
85 | # Test Builder is now making a new object for every pass/fail (que bloat?) |
86 | # and as such we can't really store any of its objects (since it will |
87 | # re-populate the registry while checking it, ewwww!) |
88 | return $obj if (ref $obj) =~ /^TB2::/; |
89 | |
a8c2c746 |
90 | # weaken immediately to avoid weird side effects |
65d35121 |
91 | return populate_weakregistry ($weak_registry, $obj ); |
a8c2c746 |
92 | }; |
93 | |
eb7aa960 |
94 | require Try::Tiny; |
a8c2c746 |
95 | for my $func (qw/try catch finally/) { |
96 | my $orig = \&{"Try::Tiny::$func"}; |
97 | *{"Try::Tiny::$func"} = sub (&;@) { |
65d35121 |
98 | populate_weakregistry( $weak_registry, $_[0] ); |
a8c2c746 |
99 | goto $orig; |
100 | } |
101 | } |
eb7aa960 |
102 | |
103 | # Some modules are known to install singletons on-load |
104 | # Load them and empty the registry |
105 | |
106 | # this loads the DT armada |
107 | $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for('test_dt_sqlite'); |
108 | |
109 | require Errno; |
110 | require DBI; |
111 | require DBD::SQLite; |
112 | require FileHandle; |
e6ff3658 |
113 | require Moo; |
eb7aa960 |
114 | |
115 | %$weak_registry = (); |
a8c2c746 |
116 | } |
117 | |
118 | { |
66917da3 |
119 | use_ok ('DBICTest'); |
a917fb06 |
120 | |
a8c2c746 |
121 | my $schema = DBICTest->init_schema; |
122 | my $rs = $schema->resultset ('Artist'); |
123 | my $storage = $schema->storage; |
a917fb06 |
124 | |
a8c2c746 |
125 | ok ($storage->connected, 'we are connected'); |
a917fb06 |
126 | |
052b8ce2 |
127 | my $row_obj = $rs->search({}, { rows => 1})->next; # so that commits/rollbacks work |
a8c2c746 |
128 | ok ($row_obj, 'row from db'); |
129 | |
052b8ce2 |
130 | # txn_do to invoke more codepaths |
a8c2c746 |
131 | my ($mc_row_obj, $pager, $pager_explicit_count) = $schema->txn_do (sub { |
132 | |
9345b14c |
133 | my $artist = $schema->resultset('Artist')->create ({ |
a8c2c746 |
134 | name => 'foo artist', |
135 | cds => [{ |
136 | title => 'foo cd', |
137 | year => 1984, |
187ec69a |
138 | tracks => [ |
139 | { title => 't1' }, |
140 | { title => 't2' }, |
141 | ], |
142 | genre => { name => 'mauve' }, |
a8c2c746 |
143 | }], |
144 | }); |
145 | |
146 | my $pg = $rs->search({}, { rows => 1})->page(2)->pager; |
147 | |
148 | my $pg_wcount = $rs->page(4)->pager->total_entries (66); |
149 | |
150 | return ($artist, $pg, $pg_wcount); |
151 | }); |
152 | |
9345b14c |
153 | # more codepaths - error handling in txn_do |
154 | { |
155 | eval { $schema->txn_do ( sub { |
156 | $storage->_dbh->begin_work; |
157 | fail ('how did we get so far?!'); |
158 | } ) }; |
159 | |
160 | eval { $schema->txn_do ( sub { |
161 | $schema->txn_do ( sub { |
162 | die "It's called EXCEPTION"; |
163 | fail ('how did we get so far?!'); |
164 | } ); |
165 | fail ('how did we get so far?!'); |
166 | } ) }; |
167 | like( $@, qr/It\'s called EXCEPTION/, 'Exception correctly propagated in nested txn_do' ); |
168 | } |
169 | |
170 | # dbh_do codepath |
187ec69a |
171 | my ($rs_bind_circref, $cond_rowobj) = $schema->storage->dbh_do ( sub { |
172 | my $row = $_[0]->schema->resultset('Artist')->new({}); |
173 | my $rs = $_[0]->schema->resultset('Artist')->search({ |
174 | name => $row, # this is deliberately bogus, see FIXME below! |
175 | }); |
176 | return ($rs, $row); |
177 | }); |
178 | |
a8c2c746 |
179 | is ($pager->next_page, 3, 'There is one more page available'); |
180 | |
181 | # based on 66 per 10 pages |
182 | is ($pager_explicit_count->last_page, 7, 'Correct last page'); |
551e711a |
183 | |
052b8ce2 |
184 | # do some population (invokes some extra codepaths) |
185 | # also exercise the guard code and the manual txn control |
186 | { |
187 | my $guard = $schema->txn_scope_guard; |
188 | # populate with bindvars |
189 | $rs->populate([{ name => 'James Bound' }]); |
190 | $guard->commit; |
191 | |
192 | $schema->txn_begin; |
193 | # populate mixed |
194 | $rs->populate([{ name => 'James Rebound', rank => \ '11' }]); |
195 | $schema->txn_commit; |
196 | |
197 | $schema->txn_begin; |
198 | # and without bindvars |
199 | $rs->populate([{ name => \ '"James Unbound"' }]); |
200 | $schema->txn_rollback; |
201 | } |
202 | |
0a03206a |
203 | # prefetching |
204 | my $cds_rs = $schema->resultset('CD'); |
205 | my $cds_with_artist = $cds_rs->search({}, { prefetch => 'artist' }); |
206 | my $cds_with_tracks = $cds_rs->search({}, { prefetch => 'tracks' }); |
207 | my $cds_with_stuff = $cds_rs->search({}, { prefetch => [ 'genre', { artist => { cds => { tracks => 'cd_single' } } } ] }); |
208 | |
209 | # implicit pref |
210 | my $cds_with_impl_artist = $cds_rs->search({}, { columns => [qw/me.title artist.name/], join => 'artist' }); |
211 | |
212 | # get_column |
213 | my $getcol_rs = $cds_rs->get_column('me.cdid'); |
214 | my $pref_getcol_rs = $cds_with_stuff->get_column('me.cdid'); |
215 | |
216 | # fire the column getters |
217 | my @throwaway = $pref_getcol_rs->all; |
218 | |
a8c2c746 |
219 | my $base_collection = { |
a8c2c746 |
220 | resultset => $rs, |
307ab4c5 |
221 | |
0a03206a |
222 | pref_precursor => $cds_rs, |
223 | |
224 | pref_rs_single => $cds_with_artist, |
225 | pref_rs_multi => $cds_with_tracks, |
226 | pref_rs_nested => $cds_with_stuff, |
227 | |
228 | pref_rs_implicit => $cds_with_impl_artist, |
229 | |
230 | pref_row_single => $cds_with_artist->next, |
231 | pref_row_multi => $cds_with_tracks->next, |
232 | pref_row_nested => $cds_with_stuff->next, |
233 | |
234 | # even though this does not leak Storable croaks on it :((( |
235 | #pref_row_implicit => $cds_with_impl_artist->next, |
236 | |
237 | get_column_rs_plain => $getcol_rs, |
238 | get_column_rs_pref => $pref_getcol_rs, |
239 | |
37aafa2e |
240 | # twice so that we make sure only one H::M object spawned |
241 | chained_resultset => $rs->search_rs ({}, { '+columns' => [ 'foo' ] } ), |
242 | chained_resultset2 => $rs->search_rs ({}, { '+columns' => [ 'bar' ] } ), |
243 | |
a8c2c746 |
244 | row_object => $row_obj, |
551e711a |
245 | |
187ec69a |
246 | mc_row_object => $mc_row_obj, |
247 | |
a8c2c746 |
248 | result_source => $rs->result_source, |
551e711a |
249 | |
4376a157 |
250 | result_source_handle => $rs->result_source->handle, |
251 | |
a8c2c746 |
252 | pager_explicit_count => $pager_explicit_count, |
187ec69a |
253 | |
254 | leaky_resultset => $rs_bind_circref, |
255 | leaky_resultset_cond => $cond_rowobj, |
a8c2c746 |
256 | }; |
574d9b69 |
257 | |
218b7c12 |
258 | # this needs to fire, even if it can't find anything |
259 | # see FIXME below |
344f761c |
260 | # we run this only on smokers - trying to establish a pattern |
261 | $rs_bind_circref->next |
262 | if ( ($ENV{TRAVIS}||'') ne 'true' and DBICTest::RunMode->is_smoker); |
218b7c12 |
263 | |
eb7aa960 |
264 | require Storable; |
4376a157 |
265 | %$base_collection = ( |
266 | %$base_collection, |
267 | refrozen => Storable::dclone( $base_collection ), |
268 | rerefrozen => Storable::dclone( Storable::dclone( $base_collection ) ), |
0a03206a |
269 | pref_row_implicit => $cds_with_impl_artist->next, |
4376a157 |
270 | schema => $schema, |
271 | storage => $storage, |
272 | sql_maker => $storage->sql_maker, |
273 | dbh => $storage->_dbh, |
cd122820 |
274 | fresh_pager => $rs->page(5)->pager, |
275 | pager => $pager, |
4376a157 |
276 | ); |
277 | |
6a43bc0c |
278 | if ($has_dt) { |
279 | my $rs = $base_collection->{icdt_rs} = $schema->resultset('Event'); |
280 | |
281 | my $now = DateTime->now; |
282 | for (1..5) { |
283 | $base_collection->{"icdt_row_$_"} = $rs->create({ |
284 | created_on => DateTime->new(year => 2011, month => 1, day => $_, time_zone => "-0${_}00" ), |
285 | starts_at => $now->clone->add(days => $_), |
286 | }); |
287 | } |
288 | |
289 | # re-search |
290 | my @dummy = $rs->all; |
291 | } |
292 | |
eb7aa960 |
293 | # dbh's are created in XS space, so pull them separately |
294 | for ( grep { defined } map { @{$_->{ChildHandles}} } values %{ {DBI->installed_drivers()} } ) { |
295 | $base_collection->{"DBI handle $_"} = $_; |
296 | } |
297 | |
187ec69a |
298 | SKIP: { |
299 | if ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') ) { |
85aaaac8 |
300 | my @w; |
301 | local $SIG{__WARN__} = sub { $_[0] =~ /\QUnhandled type: REGEXP/ ? push @w, @_ : warn @_ }; |
302 | |
303 | Test::Memory::Cycle::memory_cycle_ok ($base_collection, 'No cycles in the object collection'); |
304 | |
305 | if ( $] > 5.011 ) { |
306 | local $TODO = 'Silence warning due to RT56681'; |
307 | is (@w, 0, 'No Devel::Cycle emitted warnings'); |
308 | } |
187ec69a |
309 | } |
310 | else { |
311 | skip 'Circular ref test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_leaks'), 1; |
312 | } |
eb7aa960 |
313 | } |
574d9b69 |
314 | |
65d35121 |
315 | populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_") |
316 | for keys %$base_collection; |
551e711a |
317 | } |
318 | |
50261284 |
319 | # check that "phantom-chaining" works - we never lose track of the original $schema |
320 | # and have access to the entire tree without leaking anything |
321 | { |
322 | my $phantom; |
323 | for ( |
39b80a73 |
324 | sub { DBICTest->init_schema( sqlite_use_file => 0 ) }, |
50261284 |
325 | sub { shift->source('Artist') }, |
326 | sub { shift->resultset }, |
327 | sub { shift->result_source }, |
328 | sub { shift->schema }, |
329 | sub { shift->resultset('Artist') }, |
330 | sub { shift->find_or_create({ name => 'detachable' }) }, |
331 | sub { shift->result_source }, |
332 | sub { shift->schema }, |
333 | sub { shift->clone }, |
187ec69a |
334 | sub { shift->resultset('CD') }, |
335 | sub { shift->next }, |
336 | sub { shift->artist }, |
337 | sub { shift->search_related('cds') }, |
50261284 |
338 | sub { shift->next }, |
187ec69a |
339 | sub { shift->search_related('artist') }, |
50261284 |
340 | sub { shift->result_source }, |
341 | sub { shift->resultset }, |
342 | sub { shift->create({ name => 'detached' }) }, |
343 | sub { shift->update({ name => 'reattached' }) }, |
344 | sub { shift->discard_changes }, |
345 | sub { shift->delete }, |
346 | sub { shift->insert }, |
347 | ) { |
65d35121 |
348 | $phantom = populate_weakregistry ( $weak_registry, scalar $_->($phantom) ); |
50261284 |
349 | } |
350 | |
351 | ok( $phantom->in_storage, 'Properly deleted/reinserted' ); |
352 | is( $phantom->name, 'reattached', 'Still correct name' ); |
353 | } |
a8c2c746 |
354 | |
307ab4c5 |
355 | # Naturally we have some exceptions |
356 | my $cleared; |
96577657 |
357 | for my $addr (keys %$weak_registry) { |
358 | my $names = join "\n", keys %{$weak_registry->{$addr}{slot_names}}; |
359 | |
360 | if ($names =~ /^Test::Builder/m) { |
c8194884 |
361 | # T::B 2.0 has result objects and other fancyness |
96577657 |
362 | delete $weak_registry->{$addr}; |
c8194884 |
363 | } |
96577657 |
364 | elsif ($names =~ /^Method::Generate::(?:Accessor|Constructor)/m) { |
9345b14c |
365 | # Moo keeps globals around, this is normal |
96577657 |
366 | delete $weak_registry->{$addr}; |
9345b14c |
367 | } |
96577657 |
368 | elsif ($names =~ /^SQL::Translator::Generator::DDL::SQLite/m) { |
60fd7c30 |
369 | # SQLT::Producer::SQLite keeps global generators around for quoted |
370 | # and non-quoted DDL, allow one for each quoting style |
96577657 |
371 | delete $weak_registry->{$addr} |
372 | unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$addr}{weakref}->quote_chars}}++; |
307ab4c5 |
373 | } |
96577657 |
374 | elsif ($names =~ /^Hash::Merge/m) { |
37aafa2e |
375 | # only clear one object of a specific behavior - more would indicate trouble |
96577657 |
376 | delete $weak_registry->{$addr} |
377 | unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++; |
307ab4c5 |
378 | } |
96577657 |
379 | elsif ($names =~ /^DateTime::TimeZone/m) { |
eb7aa960 |
380 | # DT is going through a refactor it seems - let it leak zones for now |
96577657 |
381 | delete $weak_registry->{$addr}; |
eb7aa960 |
382 | } |
307ab4c5 |
383 | } |
384 | |
187ec69a |
385 | # FIXME !!! |
386 | # There is an actual strong circular reference taking place here, but because |
387 | # half of it is in XS no leaktracer sees it, and Devel::FindRef is equally |
388 | # stumped when trying to trace the origin. The problem is: |
389 | # |
728f32b5 |
390 | # $cond_object --> result_source --> schema --> storage --> $dbh --> {CachedKids} |
187ec69a |
391 | # ^ / |
392 | # \-------- bound value on prepared/cached STH <-----------/ |
393 | # |
728f32b5 |
394 | { |
395 | local $TODO = 'This fails intermittently - see RT#82942'; |
96577657 |
396 | if ( my $r = ($weak_registry->{'basic leaky_resultset_cond'}||{})->{weakref} ) { |
728f32b5 |
397 | ok(! defined $r, 'Self-referential RS conditions no longer leak!') |
398 | or $r->result_source(undef); |
399 | } |
187ec69a |
400 | } |
401 | |
65d35121 |
402 | assert_empty_weakregistry ($weak_registry); |
551e711a |
403 | |
66917da3 |
404 | # we got so far without a failure - this is a good thing |
405 | # now let's try to rerun this script under a "persistent" environment |
406 | # this is ugly and dirty but we do not yet have a Test::Embedded or |
407 | # similar |
408 | |
f3ec358e |
409 | # set up -I |
410 | require Config; |
411 | $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC); |
412 | ($ENV{PATH}) = $ENV{PATH} =~ /(.+)/; |
413 | |
414 | |
7be5717e |
415 | my $persistence_tests = { |
416 | PPerl => { |
417 | cmd => [qw/pperl --prefork=1/, __FILE__], |
418 | }, |
419 | 'CGI::SpeedyCGI' => { |
420 | cmd => [qw/speedy -- -t5/, __FILE__], |
421 | }, |
422 | }; |
66917da3 |
423 | |
424 | # scgi is smart and will auto-reap after -t amount of seconds |
7be5717e |
425 | # pperl needs an actual killer :( |
426 | $persistence_tests->{PPerl}{termcmd} = [ |
427 | $persistence_tests->{PPerl}{cmd}[0], |
428 | '--kill', |
429 | @{$persistence_tests->{PPerl}{cmd}}[ 1 .. $#{$persistence_tests->{PPerl}{cmd}} ], |
430 | ]; |
66917da3 |
431 | |
432 | SKIP: { |
433 | skip 'Test already in a persistent loop', 1 |
434 | if $ENV{DBICTEST_IN_PERSISTENT_ENV}; |
435 | |
66917da3 |
436 | skip 'Main test failed - skipping persistent env tests', 1 |
437 | unless $TB->is_passing; |
438 | |
66917da3 |
439 | local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1; |
440 | |
7be5717e |
441 | require IPC::Open2; |
442 | |
443 | for my $type (keys %$persistence_tests) { SKIP: { |
53a5200d |
444 | unless (eval "require $type") { |
445 | # Don't terminate what we didn't start |
446 | delete $persistence_tests->{$type}{termcmd}; |
447 | skip "$type module not found", 1; |
448 | } |
7be5717e |
449 | |
450 | my @cmd = @{$persistence_tests->{$type}{cmd}}; |
66917da3 |
451 | |
452 | # since PPerl is racy and sucks - just prime the "server" |
453 | { |
454 | local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1; |
7be5717e |
455 | system(@cmd); |
66917da3 |
456 | sleep 1; |
457 | |
7be5717e |
458 | # see if the thing actually runs, if not - might as well bail now |
459 | skip "Something is wrong with $type ($!)", 1 |
460 | if system(@cmd); |
66917da3 |
461 | } |
462 | |
463 | for (1,2,3) { |
7be5717e |
464 | note ("Starting run in persistent env ($type pass $_)"); |
465 | IPC::Open2::open2(my $out, undef, @cmd); |
466 | my @out_lines; |
467 | while (my $ln = <$out>) { |
468 | next if $ln =~ /^\s*$/; |
469 | push @out_lines, " $ln"; |
470 | last if $ln =~ /^\d+\.\.\d+$/; # this is persistence, we need to terminate reading on our end |
471 | } |
472 | print $_ for @out_lines; |
473 | close $out; |
474 | wait; |
475 | ok (!$?, "Run in persistent env ($type pass $_): exit $?"); |
476 | ok (scalar @out_lines, "Run in persistent env ($type pass $_): got output"); |
66917da3 |
477 | } |
478 | |
7be5717e |
479 | ok (! system (@{$persistence_tests->{$type}{termcmd}}), "killed $type server instance") |
480 | if $persistence_tests->{$type}{termcmd}; |
481 | }} |
66917da3 |
482 | } |
483 | |
551e711a |
484 | done_testing; |
66917da3 |
485 | |
486 | # just an extra precaution in case we blew away from the SKIP - since there are no |
487 | # PID files to go by (man does pperl really suck :( |
488 | END { |
489 | unless ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { |
7be5717e |
490 | close $_ for (*STDIN, *STDOUT, *STDERR); |
66917da3 |
491 | local $?; # otherwise test will inherit $? of the system() |
53a5200d |
492 | system (@{$persistence_tests->{PPerl}{termcmd}}) |
493 | if $persistence_tests->{PPerl}{termcmd}; |
66917da3 |
494 | } |
495 | } |