From: Dobrica Pavlinusic <dpavlin@rot13.org>
Date: Fri, 23 Nov 2007 00:42:50 +0000 (+0000)
Subject:  r252@brr:  dpavlin | 2007-11-23 01:42:20 +0100
X-Git-Url: http://git.rot13.org/?p=perl-cwmp.git;a=commitdiff_plain;h=f3ae2b1dbb7f1c41d64f213da3690c719da3d096

 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
--- 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
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
--- 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
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' );
+