From 07ef384ae88febde8aaccc3bfa44c2dff98c4cdd Mon Sep 17 00:00:00 2001
From: Gianni Ceccarelli <gianni.ceccarelli@net-a-porter.com>
Date: Mon, 9 Jan 2012 14:09:58 +0000
Subject: better leak tracing

---
 author_t/leaks.t | 72 +++++++++++++++++++++++++++++++++-----------------------
 1 file changed, 42 insertions(+), 30 deletions(-)

diff --git a/author_t/leaks.t b/author_t/leaks.t
index f3c811b..629f141 100644
--- a/author_t/leaks.t
+++ b/author_t/leaks.t
@@ -21,53 +21,65 @@ use Test::Most 'die';
 use Data::Printer;
 use JSON::XS;
 BEGIN { $ENV{DEBUG_MEM}=1 };
-use Dash::Leak;
+use Test::LeakTrace;
 
 my $ropts={from=>10,to=>20};
 
+sub new_obj {
+    my $obj = Foo->new(rr=>'foo');
+    $obj->rr_multi($ropts,777);
+    return $obj;
+}
+
+my $LOOP=1;
+
 my $json = JSON::XS->new->utf8;
-my $obj = Foo->new(rr=>'foo');
-$obj->rr_multi($ropts,777);
 
 subtest 'serialisation memory leak' => sub {
+    my $obj = new_obj;
     $obj=Foo->new_in_place($json->decode($json->encode($obj->as_hash)));
-    leaksz 'start memory leak';
-    for my $iter (0..2000) {
-        $obj=Foo->new_in_place($json->decode($json->encode($obj->as_hash)));
-    }
-    leaksz 'stop memory leak';
+    leaktrace {
+        for my $iter (1..$LOOP) {
+            $obj=Foo->new_in_place($json->decode($json->encode($obj->as_hash)));
+        }
+        $obj=undef;
+    } -verbose;
     ok(1,'done');
 };
 
 subtest 'accessor memory leak' => sub {
-    leaksz 'start memory leak';
-    for my $iter (0..1000) {
-        $obj->rr_multi({at=>35});
-    }
-    leaksz 'stop memory leak non-exist';
-    leaksz '...';
-    for my $iter (0..1000) {
-        $obj->rr_multi({at=>15});
-    }
-    leaksz 'stop memory leak exist';
+    my $obj = new_obj;
+    leaktrace {
+        for my $iter (1..$LOOP) {
+            $obj->rr_multi({at=>35});
+        }
+        $obj=undef;
+    } -verbose;
+    $obj = new_obj;
+    leaktrace {
+        for my $iter (1..$LOOP) {
+            $obj->rr_multi({at=>15});
+        }
+        $obj=undef;
+    } -verbose;
 
     ok(1,'done');
 };
 
 subtest 'inner memory leak' => sub {
-    my $cont = $obj->{rr__MULTIVALUED_STORAGE__}
-        {_storage};
+    my $obj = new_obj;
+    my $cont = $obj->{rr__MULTIVALUED_STORAGE__}{_storage};
 
-    leaksz 'start memory leak';
-    for my $iter (0..1000) {
-        eval { $cont->get({at=>35}) }
-    }
-    leaksz 'stop memory leak non-exist';
-    leaksz '...';
-    for my $iter (0..1000) {
-        $cont->get({at=>15});
-    }
-    leaksz 'stop memory leak exist';
+    leaktrace {
+        for my $iter (1..$LOOP) {
+            eval { $cont->get({at=>35}) }
+        }
+    } -verbose;
+    leaktrace {
+        for my $iter (1..$LOOP) {
+            $cont->get({at=>15});
+        }
+    } -verbose;
 
     ok(1,'done');
 };
-- 
cgit v1.2.3