r252@brr: dpavlin | 2007-11-23 01:42:20 +0100

 optional memory leak detector based on Devel::Events

 WARNING: it does pull half of CPAN your way (including Moose),
 so it's optional with a reason!

git-svn-id: https://perl-cwmp.googlecode.com/svn/trunk@219 836a5e1a-633d-0410-964b-294494ad4392

diff --git a/Makefile.PL b/Makefile.PL
index 723073d..902d3b6 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -36,24 +36,23 @@ features(
                recommends('Expect'),
                recommends('Net::Telnet'),
        ],
-);
-
-features(
        'HTML documentation (make html)' => [
                -default => 0,
                recommends('Pod::Xhtml'),
        ],
-);
-
-features(
        'Pod coverage tests (for developers)' => [
                -default => 0,
                recommends('Test::Pod::Coverage'),
        ],
+       'Memory leak detection (for developers)' => [
+               -default => 0,
+               recommends('Devel::Events' => '0.02'),
+               recommends('Devel::Events::Handler::ObjectTracker'),
+               recommends('Devel::Events::Generator::Objects'),
+               recommends('Devel::Size'),
+       ],
 );
 
-;
-
 my_targets();
 
 clean_files('dump/* yaml state.db html t/var/* queue');

diff --git a/lib/CWMP/MemLeak.pm b/lib/CWMP/MemLeak.pm
new file mode 100644 (file)
index 0000000..06ac5ae
--- /dev/null
+++ b/lib/CWMP/MemLeak.pm
@@ -0,0 +1,79 @@
+# Dobrica Pavlinusic, <dpavlin@rot13.org> 06/22/07 14:35:38 CEST
+package CWMP::MemLeak;
+
+use strict;
+use warnings;
+
+
+use base qw/Class::Accessor/;
+__PACKAGE__->mk_accessors( qw/
+tracker
+generator
+debug
+/ );
+
+#use Carp qw/confess/;
+use Data::Dump qw/dump/;
+use Devel::Events::Handler::ObjectTracker;
+use Devel::Events::Generator::Objects;
+use Devel::Size 'total_size';
+
+
+=head1 NAME
+
+CWMP::MemLeak - debugging module to detect memory leeks
+
+=head1 METHODS
+
+=head2 new
+
+  my $leek = CWMP::MemLeak->new({
+       debug => 1
+  });
+
+=cut
+
+sub new {
+       my $class = shift;
+       my $self = $class->SUPER::new( @_ );
+
+       warn "created ", __PACKAGE__, "(", dump( @_ ), ") object\n" if $self->debug;
+
+       $self->tracker(Devel::Events::Handler::ObjectTracker->new());
+       $self->generator(
+               Devel::Events::Generator::Objects->new(handler => $self->tracker)
+       );
+                                           
+       $self->generator->enable();
+
+       return $self;
+}
+
+=head2 report
+
+  my $size = $leek->report;
+
+=cut
+
+my $empty_array = total_size([]);
+
+sub report {
+       my $self = shift;
+
+       $self->generator->disable();
+
+       my $leaked = $self->tracker->live_objects;
+       my @leaks = keys %$leaked;
+
+       my $size = total_size([ @leaks ]) - $empty_array;
+
+       warn "leaked $size = ",dump( $leaked ),$/ if $size > 2;
+
+
+       $self->generator(undef);
+       $self->tracker(undef);
+
+       return $size;
+}
+
+1;

diff --git a/lib/CWMP/Server.pm b/lib/CWMP/Server.pm
index 13a923c..a3d909b 100644 (file)
--- a/lib/CWMP/Server.pm
+++ b/lib/CWMP/Server.pm
@@ -16,6 +16,7 @@ server
 
 use CWMP::Session;
 use CWMP::Queue;
+use CWMP::MemLeak;
 
 use Carp qw/confess/;
 use Data::Dump qw/dump/;
@@ -124,6 +125,8 @@ sub options {
 sub process_request {
        my $self = shift;
 
+       my $leak = CWMP::MemLeak->new;
+
        my $prop = $self->{server};
        confess "no server in ", ref( $self ) unless $prop;
        my $sock = $prop->{client};
@@ -146,6 +149,8 @@ sub process_request {
 
        warn "...returning to accepting new connections\n" if $prop->{debug};
 
+       $leak->report;
+
 }
 
 1;

diff --git a/t/80-leaks.t b/t/80-leaks.t
new file mode 100755 (executable)
index 0000000..c1c6768
--- /dev/null
+++ b/t/80-leaks.t
@@ -0,0 +1,25 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+my $debug = shift @ARGV;
+
+use Test::More tests => 4;
+use Data::Dump qw/dump/;
+use lib 'lib';
+
+BEGIN {
+       use_ok('CWMP::MemLeak');
+}
+
+#use Cwd qw/abs_path/;
+#ok(my $abs_path = abs_path($0), "abs_path");
+#$abs_path =~ s!/[^/]*$!/!;    #!fix-vim
+
+ok( my $leak = CWMP::MemLeak->new({
+       debug => $debug,
+}), 'new' );
+isa_ok( $leak, 'CWMP::MemLeak' );
+
+ok( ! $leak->report, 'report' );
+