t/52leaks.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Scalar::Util qw/refaddr reftype weaken/;
   6 use Carp qw/longmess/;
   7 use Try::Tiny;
   8
   9 use lib qw(t/lib);
  10 use DBICTest::RunMode;
  11
  12 my $have_test_cycle;
  13 BEGIN {
  14   require DBIx::Class::Optional::Dependencies;
  15   $have_test_cycle = DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks')
  16     and import Test::Memory::Cycle;
  17 }
  18
  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;
  74
  75   my $schema = DBICTest->init_schema;
  76   my $rs = $schema->resultset ('Artist');
  77   my $storage = $schema->storage;
  78
  79   ok ($storage->connected, 'we are connected');
  80
  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');
 105
 106   my $base_collection = {
 107     schema => $schema,
 108     storage => $storage,
 109
 110     resultset => $rs,
 111     row_object => $row_obj,
 112
 113     result_source => $rs->result_source,
 114
 115     fresh_pager => $rs->page(5)->pager,
 116     pager => $pager,
 117     pager_explicit_count => $pager_explicit_count,
 118
 119     sql_maker => $storage->sql_maker,
 120     dbh => $storage->_dbh
 121   };
 122
 123   memory_cycle_ok ($base_collection, 'No cycles in the object collection')
 124     if $have_test_cycle;
 125
 126   for (keys %$base_collection) {
 127     $weak_registry->{"basic $_"} = { weakref => $base_collection->{$_} };
 128     weaken $weak_registry->{"basic $_"}{weakref};
 129   }
 130
 131 }
 132
 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   };
 169 }
 170
 171 done_testing;