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