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; |
d12d8272 |
39 | BEGIN { |
d5e5fb4b |
40 | plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test" |
e0b2dc74 |
41 | if DBIx::Class::_ENV_::PEEPEENESS(); |
d12d8272 |
42 | } |
43 | |
a8c2c746 |
44 | use Scalar::Util qw/refaddr reftype weaken/; |
45 | use Carp qw/longmess/; |
46 | use Try::Tiny; |
a917fb06 |
47 | |
a8c2c746 |
48 | my $have_test_cycle; |
a917fb06 |
49 | BEGIN { |
226d1c35 |
50 | require DBIx::Class::Optional::Dependencies; |
a8c2c746 |
51 | $have_test_cycle = DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') |
52 | and import Test::Memory::Cycle; |
a917fb06 |
53 | } |
54 | |
a8c2c746 |
55 | # this is what holds all weakened refs to be checked for leakage |
56 | my $weak_registry = {}; |
57 | |
6a43bc0c |
58 | # whether or to invoke IC::DT |
59 | my $has_dt; |
60 | |
a8c2c746 |
61 | # Skip the heavy-duty leak tracing when just doing an install |
62 | unless (DBICTest::RunMode->is_plain) { |
f05edfd1 |
63 | # Some modules are known to install singletons on-load |
64 | # Load them before we swap out $bless_override |
65 | require DBI; |
66 | require DBD::SQLite; |
67 | require Errno; |
68 | require Class::Struct; |
69 | require FileHandle; |
307ab4c5 |
70 | require Hash::Merge; |
4376a157 |
71 | require Storable; |
f05edfd1 |
72 | |
6a43bc0c |
73 | # this loads the DT armada as well |
74 | $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for('test_dt_sqlite'); |
75 | |
a8c2c746 |
76 | no warnings qw/redefine once/; |
77 | no strict qw/refs/; |
78 | |
f05edfd1 |
79 | # redefine the bless override so that we can catch each and every object created |
80 | $bless_override = sub { |
81 | |
a8c2c746 |
82 | my $obj = CORE::bless( |
83 | $_[0], (@_ > 1) ? $_[1] : do { |
84 | my ($class, $fn, $line) = caller(); |
85 | fail ("bless() of $_[0] into $class without explicit class specification at $fn line $line") |
86 | if $class =~ /^ (?: DBIx\:\:Class | DBICTest ) /x; |
87 | $class; |
88 | } |
89 | ); |
90 | |
91 | my $slot = (sprintf '%s=%s(0x%x)', # so we don't trigger stringification |
92 | ref $obj, |
93 | reftype $obj, |
94 | refaddr $obj, |
95 | ); |
96 | |
97 | # weaken immediately to avoid weird side effects |
98 | $weak_registry->{$slot} = { weakref => $obj, strace => longmess() }; |
99 | weaken $weak_registry->{$slot}{weakref}; |
100 | |
101 | return $obj; |
102 | }; |
103 | |
104 | for my $func (qw/try catch finally/) { |
105 | my $orig = \&{"Try::Tiny::$func"}; |
106 | *{"Try::Tiny::$func"} = sub (&;@) { |
107 | |
108 | my $slot = sprintf ('CODE(0x%x)', refaddr $_[0]); |
109 | |
110 | $weak_registry->{$slot} = { weakref => $_[0], strace => longmess() }; |
111 | weaken $weak_registry->{$slot}{weakref}; |
112 | |
113 | goto $orig; |
114 | } |
115 | } |
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 | |
133 | my $artist = $rs->create ({ |
134 | name => 'foo artist', |
135 | cds => [{ |
136 | title => 'foo cd', |
137 | year => 1984, |
138 | }], |
139 | }); |
140 | |
141 | my $pg = $rs->search({}, { rows => 1})->page(2)->pager; |
142 | |
143 | my $pg_wcount = $rs->page(4)->pager->total_entries (66); |
144 | |
145 | return ($artist, $pg, $pg_wcount); |
146 | }); |
147 | |
148 | is ($pager->next_page, 3, 'There is one more page available'); |
149 | |
150 | # based on 66 per 10 pages |
151 | is ($pager_explicit_count->last_page, 7, 'Correct last page'); |
551e711a |
152 | |
052b8ce2 |
153 | # do some population (invokes some extra codepaths) |
154 | # also exercise the guard code and the manual txn control |
155 | { |
156 | my $guard = $schema->txn_scope_guard; |
157 | # populate with bindvars |
158 | $rs->populate([{ name => 'James Bound' }]); |
159 | $guard->commit; |
160 | |
161 | $schema->txn_begin; |
162 | # populate mixed |
163 | $rs->populate([{ name => 'James Rebound', rank => \ '11' }]); |
164 | $schema->txn_commit; |
165 | |
166 | $schema->txn_begin; |
167 | # and without bindvars |
168 | $rs->populate([{ name => \ '"James Unbound"' }]); |
169 | $schema->txn_rollback; |
170 | } |
171 | |
a8c2c746 |
172 | my $base_collection = { |
a8c2c746 |
173 | resultset => $rs, |
307ab4c5 |
174 | |
37aafa2e |
175 | # twice so that we make sure only one H::M object spawned |
176 | chained_resultset => $rs->search_rs ({}, { '+columns' => [ 'foo' ] } ), |
177 | chained_resultset2 => $rs->search_rs ({}, { '+columns' => [ 'bar' ] } ), |
178 | |
a8c2c746 |
179 | row_object => $row_obj, |
551e711a |
180 | |
a8c2c746 |
181 | result_source => $rs->result_source, |
551e711a |
182 | |
4376a157 |
183 | result_source_handle => $rs->result_source->handle, |
184 | |
a8c2c746 |
185 | fresh_pager => $rs->page(5)->pager, |
186 | pager => $pager, |
187 | pager_explicit_count => $pager_explicit_count, |
551e711a |
188 | |
a8c2c746 |
189 | }; |
574d9b69 |
190 | |
4376a157 |
191 | %$base_collection = ( |
192 | %$base_collection, |
193 | refrozen => Storable::dclone( $base_collection ), |
194 | rerefrozen => Storable::dclone( Storable::dclone( $base_collection ) ), |
195 | schema => $schema, |
196 | storage => $storage, |
197 | sql_maker => $storage->sql_maker, |
198 | dbh => $storage->_dbh, |
199 | ); |
200 | |
6a43bc0c |
201 | if ($has_dt) { |
202 | my $rs = $base_collection->{icdt_rs} = $schema->resultset('Event'); |
203 | |
204 | my $now = DateTime->now; |
205 | for (1..5) { |
206 | $base_collection->{"icdt_row_$_"} = $rs->create({ |
207 | created_on => DateTime->new(year => 2011, month => 1, day => $_, time_zone => "-0${_}00" ), |
208 | starts_at => $now->clone->add(days => $_), |
209 | }); |
210 | } |
211 | |
212 | # re-search |
213 | my @dummy = $rs->all; |
214 | } |
215 | |
a8c2c746 |
216 | memory_cycle_ok ($base_collection, 'No cycles in the object collection') |
217 | if $have_test_cycle; |
574d9b69 |
218 | |
a8c2c746 |
219 | for (keys %$base_collection) { |
220 | $weak_registry->{"basic $_"} = { weakref => $base_collection->{$_} }; |
221 | weaken $weak_registry->{"basic $_"}{weakref}; |
574d9b69 |
222 | } |
551e711a |
223 | } |
224 | |
50261284 |
225 | # check that "phantom-chaining" works - we never lose track of the original $schema |
226 | # and have access to the entire tree without leaking anything |
227 | { |
228 | my $phantom; |
229 | for ( |
230 | sub { DBICTest->init_schema }, |
231 | sub { shift->source('Artist') }, |
232 | sub { shift->resultset }, |
233 | sub { shift->result_source }, |
234 | sub { shift->schema }, |
235 | sub { shift->resultset('Artist') }, |
236 | sub { shift->find_or_create({ name => 'detachable' }) }, |
237 | sub { shift->result_source }, |
238 | sub { shift->schema }, |
239 | sub { shift->clone }, |
240 | sub { shift->resultset('Artist') }, |
241 | sub { shift->next }, |
242 | sub { shift->result_source }, |
243 | sub { shift->resultset }, |
244 | sub { shift->create({ name => 'detached' }) }, |
245 | sub { shift->update({ name => 'reattached' }) }, |
246 | sub { shift->discard_changes }, |
247 | sub { shift->delete }, |
248 | sub { shift->insert }, |
249 | ) { |
250 | $phantom = $_->($phantom); |
251 | |
252 | my $slot = (sprintf 'phantom %s=%s(0x%x)', # so we don't trigger stringification |
253 | ref $phantom, |
254 | reftype $phantom, |
255 | refaddr $phantom, |
256 | ); |
257 | $weak_registry->{$slot} = $phantom; |
258 | weaken $weak_registry->{$slot}; |
259 | } |
260 | |
261 | ok( $phantom->in_storage, 'Properly deleted/reinserted' ); |
262 | is( $phantom->name, 'reattached', 'Still correct name' ); |
263 | } |
a8c2c746 |
264 | |
307ab4c5 |
265 | # Naturally we have some exceptions |
266 | my $cleared; |
267 | for my $slot (keys %$weak_registry) { |
6a43bc0c |
268 | if ($slot =~ /^Test::Builder/) { |
c8194884 |
269 | # T::B 2.0 has result objects and other fancyness |
270 | delete $weak_registry->{$slot}; |
271 | } |
6a43bc0c |
272 | elsif ($slot =~ /^SQL::Translator/) { |
307ab4c5 |
273 | # SQLT is a piece of shit, leaks all over |
274 | delete $weak_registry->{$slot}; |
275 | } |
6a43bc0c |
276 | elsif ($slot =~ /^Hash::Merge/) { |
37aafa2e |
277 | # only clear one object of a specific behavior - more would indicate trouble |
307ab4c5 |
278 | delete $weak_registry->{$slot} |
279 | unless $cleared->{hash_merge_singleton}{$weak_registry->{$slot}{weakref}{behavior}}++; |
280 | } |
1f870d5a |
281 | elsif ($slot =~ /^__TxnScopeGuard__FIXUP__/) { |
48e4eac6 |
282 | delete $weak_registry->{$slot} |
283 | if $] > 5.013001 and $] < 5.013008; |
1f870d5a |
284 | } |
307ab4c5 |
285 | } |
286 | |
287 | |
a8c2c746 |
288 | # FIXME |
289 | # For reasons I can not yet fully understand the table() god-method (located in |
290 | # ::ResultSourceProxy::Table) attaches an actual source instance to each class |
291 | # as virtually *immortal* class-data. |
fa442fd5 |
292 | # For now just ignore these instances manually but there got to be a saner way |
293 | for ( map { $_->result_source_instance } ( |
a8c2c746 |
294 | 'DBICTest::BaseResult', |
295 | map { DBICTest::Schema->class ($_) } DBICTest::Schema->sources |
fa442fd5 |
296 | )) { |
297 | delete $weak_registry->{$_}; |
298 | } |
a8c2c746 |
299 | |
300 | # FIXME |
301 | # same problem goes for the schema - its classdata contains live result source |
302 | # objects, which to add insult to the injury are *different* instances from the |
fa442fd5 |
303 | # ones we ignored above |
304 | for ( values %{DBICTest::Schema->source_registrations || {}} ) { |
305 | delete $weak_registry->{$_}; |
306 | } |
a8c2c746 |
307 | |
48e4eac6 |
308 | for my $slot (sort keys %$weak_registry) { |
a8c2c746 |
309 | |
310 | ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do { |
311 | my $diag = ''; |
312 | |
313 | $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n" |
66917da3 |
314 | if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); |
a8c2c746 |
315 | |
316 | if (my $stack = $weak_registry->{$slot}{strace}) { |
317 | $diag .= " Reference first seen$stack"; |
318 | } |
319 | |
320 | diag $diag if $diag; |
321 | }; |
551e711a |
322 | } |
323 | |
66917da3 |
324 | |
325 | # we got so far without a failure - this is a good thing |
326 | # now let's try to rerun this script under a "persistent" environment |
327 | # this is ugly and dirty but we do not yet have a Test::Embedded or |
328 | # similar |
329 | |
330 | my @pperl_cmd = (qw/pperl --prefork=1/, __FILE__); |
331 | my @pperl_term_cmd = @pperl_cmd; |
332 | splice @pperl_term_cmd, 1, 0, '--kill'; |
333 | |
334 | # scgi is smart and will auto-reap after -t amount of seconds |
335 | my @scgi_cmd = (qw/speedy -- -t5/, __FILE__); |
336 | |
337 | SKIP: { |
338 | skip 'Test already in a persistent loop', 1 |
339 | if $ENV{DBICTEST_IN_PERSISTENT_ENV}; |
340 | |
341 | skip 'Persistence test disabled on regular installs', 1 |
342 | if DBICTest::RunMode->is_plain; |
343 | |
344 | skip 'Main test failed - skipping persistent env tests', 1 |
345 | unless $TB->is_passing; |
346 | |
347 | # set up -I |
348 | require Config; |
349 | local $ENV{PERL5LIB} = join ($Config::Config{path_sep}, @INC); |
350 | |
351 | local $ENV{DBICTEST_IN_PERSISTENT_ENV} = 1; |
352 | |
353 | # try with pperl |
354 | SKIP: { |
355 | skip 'PPerl persistent environment tests require PPerl', 1 |
356 | unless eval { require PPerl }; |
357 | |
358 | # since PPerl is racy and sucks - just prime the "server" |
359 | { |
360 | local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1; |
361 | system(@pperl_cmd); |
362 | sleep 1; |
363 | |
364 | # see if it actually runs - if not might as well bail now |
365 | skip "Something is wrong with pperl ($!)", 1 |
366 | if system(@pperl_cmd); |
367 | } |
368 | |
369 | for (1,2,3) { |
370 | system(@pperl_cmd); |
371 | ok (!$?, "Run in persistent env (PPerl pass $_): exit $?"); |
372 | } |
373 | |
374 | ok (! system (@pperl_term_cmd), 'killed pperl instance'); |
375 | } |
376 | |
377 | # try with speedy-cgi |
378 | SKIP: { |
379 | skip 'SPeedyCGI persistent environment tests require CGI::SpeedyCGI', 1 |
380 | unless eval { require CGI::SpeedyCGI }; |
381 | |
382 | { |
383 | local $ENV{DBICTEST_PERSISTENT_ENV_BAIL_EARLY} = 1; |
384 | skip "Something is wrong with speedy ($!)", 1 |
385 | if system(@scgi_cmd); |
386 | sleep 1; |
387 | } |
388 | |
389 | for (1,2,3) { |
390 | system(@scgi_cmd); |
391 | ok (!$?, "Run in persistent env (SpeedyCGI pass $_): exit $?"); |
392 | } |
393 | } |
394 | } |
395 | |
551e711a |
396 | done_testing; |
66917da3 |
397 | |
398 | # just an extra precaution in case we blew away from the SKIP - since there are no |
399 | # PID files to go by (man does pperl really suck :( |
400 | END { |
401 | unless ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { |
402 | close STDOUT; |
403 | close STDERR; |
404 | local $?; # otherwise test will inherit $? of the system() |
405 | system (@pperl_term_cmd); |
406 | } |
407 | } |