From: Peter Rabbitson <ribasushi@cpan.org>
Date: Tue, 14 Jan 2014 05:32:45 +0000 (+0100)
Subject: "Fun" with Devel::MAT
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c3009414d045c24a8a09b05cf987764256fff203;p=dbsrgits%2FDBIx-Class-Historic.git

"Fun" with Devel::MAT
---

diff --git a/cmpmat b/cmpmat
new file mode 100644
index 0000000..b70e803
--- /dev/null
+++ b/cmpmat
@@ -0,0 +1,65 @@
+use strictures;
+use Devel::Dwarn;
+
+use Devel::MAT::Dumpfile;
+
+my ($sv_counts, $svmap, $seentypes, $refholders );
+
+sub ha { sprintf '0x%x', $_[0] }
+
+for my $dmp (qw(dump_200356 dump_300033)) {
+  my $d = Devel::MAT::Dumpfile->load($dmp);
+
+  Ddie [ $d->sv_at( 0x3d1e370 )->values ];
+
+  for my $sv ($d->heap) {
+    next unless $sv->type eq 'SCALAR' and ! grep { defined $sv->$_ } qw(qq_pv pv pvlen iv uv nv ourstash);
+    $sv_counts->{join "\0", map { (defined $sv->$_) ? $sv->$_ :  'UNDEF' } (qw(qq_pv pv pvlen iv uv nv ourstash))}{$dmp}++;
+    $svmap->{$dmp}{ha $sv->addr} = { sv => $sv };
+  }
+
+  for my $sv ($d->heap) {
+    for ( values %{ {$sv->outrefs_strong} } ) {
+      if (my $slot = $svmap->{$dmp}{ha $_->addr}) {
+        push @{$slot->{refs}}, $sv;
+        $slot->{reftypes}{$sv->type}++;
+      }
+    }
+  }
+
+
+
+  for my $addr ( keys %{$svmap->{$dmp}}) {
+    my $slot = $svmap->{$dmp}{$addr};
+    delete $svmap->{$dmp}{$addr} if $slot->{sv}->refcnt != scalar @{ $slot->{refs} || [] };
+
+    my $refsummary = join ":", map { $_ => $slot->{reftypes}{$_} } sort keys %{$slot->{reftypes}};
+
+    if ($refsummary eq 'HASH:1') {
+      $seentypes->{$dmp}{$refsummary}++;
+
+      $refholders->{$dmp}{$slot->{refs}[0]->desc_addr}++;
+    }
+    else {
+      delete $svmap->{$dmp}{$addr};
+    }
+  }
+
+#  for my $reflist (values %{$refmap->{$dmp}}) {
+#    next unless $reflist;
+#    my $cnts;
+#    $cnts->{$_->type}++ for @$reflist;
+#    Ddie $cnts;
+#  }
+
+#  local $Data::Dumper::Maxdepth = 3;
+#  Ddie $refmap;
+}
+
+for (keys %$sv_counts) {
+  my ($l, $r) = values %{$sv_counts->{$_}};
+  delete $sv_counts->{$_} if ( ($l||0) == ($r||0) );
+}
+
+Dwarn [$sv_counts, $seentypes, $refholders ];
+
diff --git a/t/52leaks.t b/t/52leaks.t
index af8caa2..e036259 100644
--- a/t/52leaks.t
+++ b/t/52leaks.t
@@ -332,38 +332,38 @@ unless (DBICTest::RunMode->is_plain) {
 
 # check that "phantom-chaining" works - we never lose track of the original $schema
 # and have access to the entire tree without leaking anything
-{
+while (1) {
   my $phantom;
   for (
-    sub { DBICTest->init_schema( sqlite_use_file => 0 ) },
-    sub { shift->source('Artist') },
-    sub { shift->resultset },
-    sub { shift->result_source },
-    sub { shift->schema },
-    sub { shift->resultset('Artist') },
-    sub { shift->find_or_create({ name => 'detachable' }) },
-    sub { shift->result_source },
-    sub { shift->schema },
-    sub { shift->clone },
-    sub { shift->resultset('CD') },
-    sub { shift->next },
-    sub { shift->artist },
-    sub { shift->search_related('cds') },
-    sub { shift->next },
-    sub { shift->search_related('artist') },
-    sub { shift->result_source },
-    sub { shift->resultset },
-    sub { shift->create({ name => 'detached' }) },
-    sub { shift->update({ name => 'reattached' }) },
-    sub { shift->discard_changes },
-    sub { shift->delete },
-    sub { shift->insert },
+    sub { DBICTest->init_schema( sqlite_use_file => 0, no_deploy => 1 ) },
+#    sub { shift->source('Artist') },
+#    sub { shift->resultset },
+#    sub { shift->result_source },
+#    sub { shift->schema },
+#    sub { shift->resultset('Artist') },
+#    sub { shift->find_or_create({ name => 'detachable' }) },
+#    sub { shift->result_source },
+#    sub { shift->schema },
+#    sub { shift->clone },
+#    sub { shift->resultset('CD') },
+#    sub { shift->next },
+#    sub { shift->artist },
+#    sub { shift->search_related('cds') },
+#    sub { shift->next },
+#    sub { shift->search_related('artist') },
+#    sub { shift->result_source },
+#    sub { shift->resultset },
+#    sub { shift->create({ name => 'detached' }) },
+#    sub { shift->update({ name => 'reattached' }) },
+#    sub { shift->discard_changes },
+#    sub { shift->delete },
+#    sub { shift->insert },
   ) {
     $phantom = populate_weakregistry ( $weak_registry, scalar $_->($phantom) );
   }
 
-  ok( $phantom->in_storage, 'Properly deleted/reinserted' );
-  is( $phantom->name, 'reattached', 'Still correct name' );
+#  ok( $phantom->in_storage, 'Properly deleted/reinserted' );
+#  is( $phantom->name, 'reattached', 'Still correct name' );
 }
 
 # Naturally we have some exceptions
diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
index ef178f9..b44c071 100644
--- a/t/lib/DBICTest/Util/LeakTracer.pm
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -14,6 +14,8 @@ use constant {
   SKIP_SCALAR_REFS => ( $] > 5.017 ) ? 1 : 0,
 };
 
+use Devel::MAT::Dumper -max_string => -1;
+
 use base 'Exporter';
 our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr visit_refs);
 
@@ -32,6 +34,9 @@ sub _describe_ref {
   ;
 }
 
+warn "\nPID $$\n";
+
+my ($cycle_cnt, $max, $dumpnext) = (0, 0);
 sub populate_weakregistry {
   my ($weak_registry, $target, $note) = @_;
 
@@ -52,6 +57,8 @@ sub populate_weakregistry {
   for my $reg (values %reg_of_regs) {
     (defined $reg->{$_}{weakref}) or delete $reg->{$_}
       for keys %$reg;
+
+    $max = scalar keys %$reg if $max < scalar keys %$reg;
   }
 
   # FIXME/INVESTIGATE - something fishy is going on with refs to plain
@@ -74,6 +81,25 @@ sub populate_weakregistry {
     $weak_registry->{$refaddr}{slot_names}{$note} = 1;
   }
 
+  $max = 0 if $cycle_cnt == 8000;
+  $dumpnext = 1 unless ( ++$cycle_cnt % 100_000 );
+  unless (++$cycle_cnt % 10_000) {
+    if (-f "/proc/$$/stat") {
+      my $proc_stat = do { local (@ARGV, $/) = "/proc/$$/stat"; <> };
+        my ($vsz) = map { $_ / 1024 }
+        (split (/\s+/, $proc_stat))[-22];  # go backwards because the %s of the pr
+
+      printf STDERR "#\n# VSIZE:%dKiB\n", $vsz
+
+    }
+  }
+
+#  if ($dumpnext and ( (scalar keys %$weak_registry) == $max )) {
+#    undef $dumpnext;
+#    Devel::MAT::Dumper::dump( "/tmp/dump_$cycle_cnt" );
+#    exit if $cycle_cnt >= 900_000;
+#  }
+
   $target;
 }