Commit | Line | Data |
a917fb06 |
1 | use strict; |
2 | use warnings; |
226d1c35 |
3 | |
f05edfd1 |
4 | # Do the override as early as possible so that CORE::bless doesn't get compiled away |
5 | # We will replace $bless_override only if we are in author mode |
6 | my $bless_override; |
7 | BEGIN { |
8 | $bless_override = sub { |
9 | CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ); |
10 | }; |
11 | *CORE::GLOBAL::bless = sub { goto $bless_override }; |
12 | } |
13 | |
a917fb06 |
14 | use Test::More; |
a8c2c746 |
15 | use Scalar::Util qw/refaddr reftype weaken/; |
16 | use Carp qw/longmess/; |
17 | use Try::Tiny; |
a917fb06 |
18 | |
19 | use lib qw(t/lib); |
a8c2c746 |
20 | use DBICTest::RunMode; |
a917fb06 |
21 | |
a8c2c746 |
22 | my $have_test_cycle; |
a917fb06 |
23 | BEGIN { |
226d1c35 |
24 | require DBIx::Class::Optional::Dependencies; |
a8c2c746 |
25 | $have_test_cycle = DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') |
26 | and import Test::Memory::Cycle; |
a917fb06 |
27 | } |
28 | |
a8c2c746 |
29 | # this is what holds all weakened refs to be checked for leakage |
30 | my $weak_registry = {}; |
31 | |
32 | # Skip the heavy-duty leak tracing when just doing an install |
33 | unless (DBICTest::RunMode->is_plain) { |
f05edfd1 |
34 | |
35 | # Some modules are known to install singletons on-load |
36 | # Load them before we swap out $bless_override |
37 | require DBI; |
38 | require DBD::SQLite; |
39 | require Errno; |
40 | require Class::Struct; |
41 | require FileHandle; |
42 | |
a8c2c746 |
43 | no warnings qw/redefine once/; |
44 | no strict qw/refs/; |
45 | |
f05edfd1 |
46 | # redefine the bless override so that we can catch each and every object created |
47 | $bless_override = sub { |
48 | |
a8c2c746 |
49 | my $obj = CORE::bless( |
50 | $_[0], (@_ > 1) ? $_[1] : do { |
51 | my ($class, $fn, $line) = caller(); |
52 | fail ("bless() of $_[0] into $class without explicit class specification at $fn line $line") |
53 | if $class =~ /^ (?: DBIx\:\:Class | DBICTest ) /x; |
54 | $class; |
55 | } |
56 | ); |
57 | |
58 | my $slot = (sprintf '%s=%s(0x%x)', # so we don't trigger stringification |
59 | ref $obj, |
60 | reftype $obj, |
61 | refaddr $obj, |
62 | ); |
63 | |
64 | # weaken immediately to avoid weird side effects |
65 | $weak_registry->{$slot} = { weakref => $obj, strace => longmess() }; |
66 | weaken $weak_registry->{$slot}{weakref}; |
67 | |
68 | return $obj; |
69 | }; |
70 | |
71 | for my $func (qw/try catch finally/) { |
72 | my $orig = \&{"Try::Tiny::$func"}; |
73 | *{"Try::Tiny::$func"} = sub (&;@) { |
74 | |
75 | my $slot = sprintf ('CODE(0x%x)', refaddr $_[0]); |
76 | |
77 | $weak_registry->{$slot} = { weakref => $_[0], strace => longmess() }; |
78 | weaken $weak_registry->{$slot}{weakref}; |
79 | |
80 | goto $orig; |
81 | } |
82 | } |
83 | } |
84 | |
85 | { |
86 | require DBICTest; |
a917fb06 |
87 | |
a8c2c746 |
88 | my $schema = DBICTest->init_schema; |
89 | my $rs = $schema->resultset ('Artist'); |
90 | my $storage = $schema->storage; |
a917fb06 |
91 | |
a8c2c746 |
92 | ok ($storage->connected, 'we are connected'); |
a917fb06 |
93 | |
a8c2c746 |
94 | my $row_obj = $rs->next; |
95 | ok ($row_obj, 'row from db'); |
96 | |
97 | my ($mc_row_obj, $pager, $pager_explicit_count) = $schema->txn_do (sub { |
98 | |
99 | my $artist = $rs->create ({ |
100 | name => 'foo artist', |
101 | cds => [{ |
102 | title => 'foo cd', |
103 | year => 1984, |
104 | }], |
105 | }); |
106 | |
107 | my $pg = $rs->search({}, { rows => 1})->page(2)->pager; |
108 | |
109 | my $pg_wcount = $rs->page(4)->pager->total_entries (66); |
110 | |
111 | return ($artist, $pg, $pg_wcount); |
112 | }); |
113 | |
114 | is ($pager->next_page, 3, 'There is one more page available'); |
115 | |
116 | # based on 66 per 10 pages |
117 | is ($pager_explicit_count->last_page, 7, 'Correct last page'); |
551e711a |
118 | |
a8c2c746 |
119 | my $base_collection = { |
120 | schema => $schema, |
121 | storage => $storage, |
dc35bbe6 |
122 | |
a8c2c746 |
123 | resultset => $rs, |
124 | row_object => $row_obj, |
551e711a |
125 | |
a8c2c746 |
126 | result_source => $rs->result_source, |
551e711a |
127 | |
a8c2c746 |
128 | fresh_pager => $rs->page(5)->pager, |
129 | pager => $pager, |
130 | pager_explicit_count => $pager_explicit_count, |
551e711a |
131 | |
a8c2c746 |
132 | sql_maker => $storage->sql_maker, |
133 | dbh => $storage->_dbh |
134 | }; |
574d9b69 |
135 | |
a8c2c746 |
136 | memory_cycle_ok ($base_collection, 'No cycles in the object collection') |
137 | if $have_test_cycle; |
574d9b69 |
138 | |
a8c2c746 |
139 | for (keys %$base_collection) { |
140 | $weak_registry->{"basic $_"} = { weakref => $base_collection->{$_} }; |
141 | weaken $weak_registry->{"basic $_"}{weakref}; |
574d9b69 |
142 | } |
143 | |
551e711a |
144 | } |
145 | |
a8c2c746 |
146 | memory_cycle_ok($weak_registry, 'No cycles in the weakened object collection') |
147 | if $have_test_cycle; |
148 | |
149 | # FIXME |
150 | # For reasons I can not yet fully understand the table() god-method (located in |
151 | # ::ResultSourceProxy::Table) attaches an actual source instance to each class |
152 | # as virtually *immortal* class-data. |
153 | # For now just blow away these instances manually but there got to be a saner way |
154 | $_->result_source_instance(undef) for ( |
155 | 'DBICTest::BaseResult', |
156 | map { DBICTest::Schema->class ($_) } DBICTest::Schema->sources |
157 | ); |
158 | |
159 | # FIXME |
160 | # same problem goes for the schema - its classdata contains live result source |
161 | # objects, which to add insult to the injury are *different* instances from the |
162 | # ones we destroyed above |
163 | DBICTest::Schema->source_registrations(undef); |
164 | |
165 | my $tb = Test::More->builder; |
166 | for my $slot (keys %$weak_registry) { |
167 | # SQLT is a piece of shit, leaks all over |
168 | next if $slot =~ /^SQL\:\:Translator/; |
169 | |
170 | ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do { |
171 | my $diag = ''; |
172 | |
173 | $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n" |
174 | if ( $ENV{TEST_VERBOSE} && try { require Devel::FindRef }); |
175 | |
176 | if (my $stack = $weak_registry->{$slot}{strace}) { |
177 | $diag .= " Reference first seen$stack"; |
178 | } |
179 | |
180 | diag $diag if $diag; |
181 | }; |
551e711a |
182 | } |
183 | |
184 | done_testing; |