t/52_memory_leak.t

   1
   2 # This was discussed here:
   3 # http://groups.google.com/group/DBM-Deep/browse_thread/thread/a6b8224ffec21bab
   4 # brought up by Alex Gallichotte
   5
   6 use strict;
   7 use warnings FATAL => 'all';
   8
   9 use Test::More;
  10 use DBM::Deep;
  11
  12 plan skip_all => "Need to figure out what platforms this runs on";
  13
  14 use t::common qw( new_fh );
  15
  16 my ($fh, $filename) = new_fh();
  17 my $db = DBM::Deep->new( file => $filename, fh => $fh, );
  18
  19 my $todo  = 1000;
  20 my $allow = $todo*0.02; # NOTE: a 2% fail rate is hardly a failure
  21
  22 $db->{randkey()} = 1 for 1 .. 1000;
  23
  24 plan tests => $todo*2;
  25
  26 my $error_count = 0;
  27 my @mem = (mem(0), mem(1));
  28 for my $i (1 .. $todo) {
  29     $db->{randkey()} = [@mem];
  30
  31     ## DEBUG ## print STDERR " @mem     \r";
  32
  33     my @tm = (mem(0), mem(1));
  34
  35     skip( not($mem[0]), ($tm[0] <= $mem[0] or --$allow>0) );
  36     skip( not($mem[1]), ($tm[1] <= $mem[1] or --$allow>0) );
  37
  38     $error_count ++ if $tm[0] > $mem[0] or $tm[1] > $mem[1];
  39     die " ERROR: that's enough failures to prove the point ... " if $error_count > 20;
  40
  41     @mem = @tm;
  42 }
  43
  44 sub randkey {
  45     our $i ++;
  46     my @k = map { int rand 100 } 1 .. 10;
  47     local $" = "-";
  48
  49     return "$i-@k";
  50 }
  51
  52 sub mem {
  53     open my $in, "/proc/$$/statm" or return 0;
  54     my $line = [ split m/\s+/, <$in> ];
  55     close $in;
  56
  57     return $line->[shift];
  58 }
  59
  60 __END__
  61 /proc/[number]/statm
  62
  63       Provides information about memory status in pages.  The columns are:
  64
  65           size       total program size
  66           resident   resident set size
  67           share      shared pages
  68           text       text (code)
  69           lib        library
  70           data       data/stack
  71           dt         dirty pages (unused in Linux 2.6)