do not use "me" on the related_resultset pessimization
[dbsrgits/DBIx-Class-Historic.git] / t / 52leaks.t
CommitLineData
f05edfd1 1# Do the override as early as possible so that CORE::bless doesn't get compiled away
2# We will replace $bless_override only if we are in author mode
3my $bless_override;
4BEGIN {
5 $bless_override = sub {
6 CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() );
7 };
8 *CORE::GLOBAL::bless = sub { goto $bless_override };
9}
10
50261284 11use strict;
12use warnings;
a917fb06 13use Test::More;
d5e5fb4b 14
15use lib qw(t/lib);
16use DBICTest::RunMode;
d12d8272 17BEGIN {
d5e5fb4b 18 plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
19 if DBICTest::RunMode->peepeeness;
d12d8272 20}
21
a8c2c746 22use Scalar::Util qw/refaddr reftype weaken/;
23use Carp qw/longmess/;
24use Try::Tiny;
a917fb06 25
a8c2c746 26my $have_test_cycle;
a917fb06 27BEGIN {
226d1c35 28 require DBIx::Class::Optional::Dependencies;
a8c2c746 29 $have_test_cycle = DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks')
30 and import Test::Memory::Cycle;
a917fb06 31}
32
a8c2c746 33# this is what holds all weakened refs to be checked for leakage
34my $weak_registry = {};
35
36# Skip the heavy-duty leak tracing when just doing an install
37unless (DBICTest::RunMode->is_plain) {
f05edfd1 38
39 # Some modules are known to install singletons on-load
40 # Load them before we swap out $bless_override
41 require DBI;
42 require DBD::SQLite;
43 require Errno;
44 require Class::Struct;
45 require FileHandle;
307ab4c5 46 require Hash::Merge;
4376a157 47 require Storable;
f05edfd1 48
a8c2c746 49 no warnings qw/redefine once/;
50 no strict qw/refs/;
51
f05edfd1 52 # redefine the bless override so that we can catch each and every object created
53 $bless_override = sub {
54
a8c2c746 55 my $obj = CORE::bless(
56 $_[0], (@_ > 1) ? $_[1] : do {
57 my ($class, $fn, $line) = caller();
58 fail ("bless() of $_[0] into $class without explicit class specification at $fn line $line")
59 if $class =~ /^ (?: DBIx\:\:Class | DBICTest ) /x;
60 $class;
61 }
62 );
63
64 my $slot = (sprintf '%s=%s(0x%x)', # so we don't trigger stringification
65 ref $obj,
66 reftype $obj,
67 refaddr $obj,
68 );
69
70 # weaken immediately to avoid weird side effects
71 $weak_registry->{$slot} = { weakref => $obj, strace => longmess() };
72 weaken $weak_registry->{$slot}{weakref};
73
74 return $obj;
75 };
76
77 for my $func (qw/try catch finally/) {
78 my $orig = \&{"Try::Tiny::$func"};
79 *{"Try::Tiny::$func"} = sub (&;@) {
80
81 my $slot = sprintf ('CODE(0x%x)', refaddr $_[0]);
82
83 $weak_registry->{$slot} = { weakref => $_[0], strace => longmess() };
84 weaken $weak_registry->{$slot}{weakref};
85
86 goto $orig;
87 }
88 }
89}
90
91{
92 require DBICTest;
a917fb06 93
a8c2c746 94 my $schema = DBICTest->init_schema;
95 my $rs = $schema->resultset ('Artist');
96 my $storage = $schema->storage;
a917fb06 97
a8c2c746 98 ok ($storage->connected, 'we are connected');
a917fb06 99
052b8ce2 100 my $row_obj = $rs->search({}, { rows => 1})->next; # so that commits/rollbacks work
a8c2c746 101 ok ($row_obj, 'row from db');
102
052b8ce2 103 # txn_do to invoke more codepaths
a8c2c746 104 my ($mc_row_obj, $pager, $pager_explicit_count) = $schema->txn_do (sub {
105
106 my $artist = $rs->create ({
107 name => 'foo artist',
108 cds => [{
109 title => 'foo cd',
110 year => 1984,
111 }],
112 });
113
114 my $pg = $rs->search({}, { rows => 1})->page(2)->pager;
115
116 my $pg_wcount = $rs->page(4)->pager->total_entries (66);
117
118 return ($artist, $pg, $pg_wcount);
119 });
120
121 is ($pager->next_page, 3, 'There is one more page available');
122
123 # based on 66 per 10 pages
124 is ($pager_explicit_count->last_page, 7, 'Correct last page');
551e711a 125
052b8ce2 126 # do some population (invokes some extra codepaths)
127 # also exercise the guard code and the manual txn control
128 {
129 my $guard = $schema->txn_scope_guard;
130 # populate with bindvars
131 $rs->populate([{ name => 'James Bound' }]);
132 $guard->commit;
133
134 $schema->txn_begin;
135 # populate mixed
136 $rs->populate([{ name => 'James Rebound', rank => \ '11' }]);
137 $schema->txn_commit;
138
139 $schema->txn_begin;
140 # and without bindvars
141 $rs->populate([{ name => \ '"James Unbound"' }]);
142 $schema->txn_rollback;
143 }
144
a8c2c746 145 my $base_collection = {
a8c2c746 146 resultset => $rs,
307ab4c5 147
37aafa2e 148 # twice so that we make sure only one H::M object spawned
149 chained_resultset => $rs->search_rs ({}, { '+columns' => [ 'foo' ] } ),
150 chained_resultset2 => $rs->search_rs ({}, { '+columns' => [ 'bar' ] } ),
151
a8c2c746 152 row_object => $row_obj,
551e711a 153
a8c2c746 154 result_source => $rs->result_source,
551e711a 155
4376a157 156 result_source_handle => $rs->result_source->handle,
157
a8c2c746 158 fresh_pager => $rs->page(5)->pager,
159 pager => $pager,
160 pager_explicit_count => $pager_explicit_count,
551e711a 161
a8c2c746 162 };
574d9b69 163
4376a157 164 %$base_collection = (
165 %$base_collection,
166 refrozen => Storable::dclone( $base_collection ),
167 rerefrozen => Storable::dclone( Storable::dclone( $base_collection ) ),
168 schema => $schema,
169 storage => $storage,
170 sql_maker => $storage->sql_maker,
171 dbh => $storage->_dbh,
172 );
173
a8c2c746 174 memory_cycle_ok ($base_collection, 'No cycles in the object collection')
175 if $have_test_cycle;
574d9b69 176
a8c2c746 177 for (keys %$base_collection) {
178 $weak_registry->{"basic $_"} = { weakref => $base_collection->{$_} };
179 weaken $weak_registry->{"basic $_"}{weakref};
574d9b69 180 }
551e711a 181}
182
50261284 183# check that "phantom-chaining" works - we never lose track of the original $schema
184# and have access to the entire tree without leaking anything
185{
186 my $phantom;
187 for (
188 sub { DBICTest->init_schema },
189 sub { shift->source('Artist') },
190 sub { shift->resultset },
191 sub { shift->result_source },
192 sub { shift->schema },
193 sub { shift->resultset('Artist') },
194 sub { shift->find_or_create({ name => 'detachable' }) },
195 sub { shift->result_source },
196 sub { shift->schema },
197 sub { shift->clone },
198 sub { shift->resultset('Artist') },
199 sub { shift->next },
200 sub { shift->result_source },
201 sub { shift->resultset },
202 sub { shift->create({ name => 'detached' }) },
203 sub { shift->update({ name => 'reattached' }) },
204 sub { shift->discard_changes },
205 sub { shift->delete },
206 sub { shift->insert },
207 ) {
208 $phantom = $_->($phantom);
209
210 my $slot = (sprintf 'phantom %s=%s(0x%x)', # so we don't trigger stringification
211 ref $phantom,
212 reftype $phantom,
213 refaddr $phantom,
214 );
215 $weak_registry->{$slot} = $phantom;
216 weaken $weak_registry->{$slot};
217 }
218
219 ok( $phantom->in_storage, 'Properly deleted/reinserted' );
220 is( $phantom->name, 'reattached', 'Still correct name' );
221}
a8c2c746 222
307ab4c5 223# Naturally we have some exceptions
224my $cleared;
225for my $slot (keys %$weak_registry) {
c8194884 226 if ($slot =~ /^\QTest::Builder/) {
227 # T::B 2.0 has result objects and other fancyness
228 delete $weak_registry->{$slot};
229 }
230 elsif ($slot =~ /^\QSQL::Translator/) {
307ab4c5 231 # SQLT is a piece of shit, leaks all over
232 delete $weak_registry->{$slot};
233 }
d12d8272 234 elsif ($slot =~ /^\QHash::Merge/) {
37aafa2e 235 # only clear one object of a specific behavior - more would indicate trouble
307ab4c5 236 delete $weak_registry->{$slot}
237 unless $cleared->{hash_merge_singleton}{$weak_registry->{$slot}{weakref}{behavior}}++;
238 }
1f870d5a 239 elsif ($slot =~ /^__TxnScopeGuard__FIXUP__/) {
48e4eac6 240 delete $weak_registry->{$slot}
241 if $] > 5.013001 and $] < 5.013008;
1f870d5a 242 }
307ab4c5 243}
244
245
a8c2c746 246# FIXME
247# For reasons I can not yet fully understand the table() god-method (located in
248# ::ResultSourceProxy::Table) attaches an actual source instance to each class
249# as virtually *immortal* class-data.
250# For now just blow away these instances manually but there got to be a saner way
251$_->result_source_instance(undef) for (
252 'DBICTest::BaseResult',
253 map { DBICTest::Schema->class ($_) } DBICTest::Schema->sources
254);
255
256# FIXME
257# same problem goes for the schema - its classdata contains live result source
258# objects, which to add insult to the injury are *different* instances from the
259# ones we destroyed above
260DBICTest::Schema->source_registrations(undef);
261
262my $tb = Test::More->builder;
48e4eac6 263for my $slot (sort keys %$weak_registry) {
a8c2c746 264
265 ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
266 my $diag = '';
267
268 $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
269 if ( $ENV{TEST_VERBOSE} && try { require Devel::FindRef });
270
271 if (my $stack = $weak_registry->{$slot}{strace}) {
272 $diag .= " Reference first seen$stack";
273 }
274
275 diag $diag if $diag;
276 };
551e711a 277}
278
279done_testing;