From: jettero@cpan.org <jettero@cpan.org>
Date: Thu, 17 Jul 2008 20:20:28 +0000 (+0000)
Subject: here's a test that shows the memory leak
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b391d9ac2267beb9625239d234f3d9ee8b411ae3;p=dbsrgits%2FDBM-Deep.git

here's a test that shows the memory leak

git-svn-id: http://svn.ali.as/cpan/trunk/DBM-Deep@3821 88f4d9cd-8a04-0410-9d60-8f63309c3137
---

diff --git a/t/52_memory_leak.t b/t/52_memory_leak.t
new file mode 100644
index 0000000..19c4910
--- /dev/null
+++ b/t/52_memory_leak.t
@@ -0,0 +1,61 @@
+
+use strict;
+use Test;
+use DBM::Deep;
+use t::common qw( new_fh );
+
+my ($fh, $filename) = new_fh();
+my $db = DBM::Deep->new( file => $filename, fh => $fh, );
+
+my $todo = 1000;
+
+$db->{randkey()} = 1 for 1 .. 1000;
+
+plan tests => $todo*2;
+
+my $error_count = 0;
+my @mem = (mem(0), mem(1));
+for my $i (1 .. $todo) {
+    $db->{randkey()} = [@mem];
+
+    print STDERR " @mem     \r";
+
+    my @tm = (mem(0), mem(1));
+
+    skip( not($mem[0]), $tm[0] <= $mem[0] );
+    skip( not($mem[1]), $tm[1] <= $mem[1] );
+
+    $error_count ++ if $tm[0] > $mem[0] or $tm[1] > $mem[1];
+    die " ERROR: that's enough failures to prove the point ... " if $error_count > 20;
+
+    @mem = @tm;
+}
+
+sub randkey {
+    our $i ++;
+    my @k = map { int rand 100 } 1 .. 10;
+    local $" = "-";
+
+    return "$i-@k";
+}
+
+sub mem {
+    open my $in, "/proc/$$/statm" or return 0;
+    my $line = [ split m/\s+/, <$in> ];
+    close $in;
+
+    return $line->[shift];
+}
+
+__END__
+/proc/[number]/statm
+
+      Provides information about memory status in pages.  The columns are:
+
+          size       total program size
+          resident   resident set size
+          share      shared pages
+          text       text (code)
+          lib        library
+          data       data/stack
+          dt         dirty pages (unused in Linux 2.6)