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