Mercurial > pub > Impl
changeset 188:029c9610528c
Memory leak tests in IMPL::Web::View
author | cin |
---|---|
date | Tue, 03 Apr 2012 20:08:42 +0400 |
parents | 927653d01f4f |
children | 08015e2803f1 |
files | Lib/IMPL/DOM/Node.pm Lib/IMPL/Profiler/Memory.pm Lib/IMPL/Test.pm Lib/IMPL/Web/View/TTControl.pm Lib/IMPL/Web/View/TTDocument.pm _test/Resources/TTView/My/Org/Panel.tt _test/Resources/TTView/simple.tt _test/Test/DOM/Node.pm _test/Test/Web/View.pm _test/Web.t |
diffstat | 10 files changed, 183 insertions(+), 85 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/IMPL/DOM/Node.pm Tue Apr 03 07:54:25 2012 +0400 +++ b/Lib/IMPL/DOM/Node.pm Tue Apr 03 20:08:42 2012 +0400 @@ -370,6 +370,8 @@ my $this = shift; my $name = shift; + return unless defined $name; + if (my $method = $this->can($name)) { unshift @_,$this; # use goto to preserve calling context
--- a/Lib/IMPL/Profiler/Memory.pm Tue Apr 03 07:54:25 2012 +0400 +++ b/Lib/IMPL/Profiler/Memory.pm Tue Apr 03 20:08:42 2012 +0400 @@ -4,54 +4,106 @@ use Carp qw(longmess shortmess); use Scalar::Util qw(refaddr weaken isweak); -my %instances; +my %listeners; +my $trapped; BEGIN { - *CORE::GLOBAL::bless = sub { - $_[1] |= caller unless $_[1]; - my $ref = CORE::bless $_[0],$_[1]; + $trapped = 0; +} - my $id = refaddr($ref); +sub import { + if (not $trapped) { + *CORE::GLOBAL::bless = sub { + $_[1] |= caller unless $_[1]; + my $ref = CORE::bless $_[0],$_[1]; + + $_->track($ref) foreach values %listeners; + + return $ref; + }; + $trapped = 1; + } +} - $instances{$id} = { - Class => $_[1], - WeakRef => $ref - }; +sub _ConnectListener { + my ($self,$listener) = @_; + + die "Invalid listener" unless ref $listener; + + $listeners{refaddr($listener)} = $listener; +} - weaken($instances{$id}{WeakRef}); +sub _RemoveListener { + my ($self,$listener) = @_; + + die "Invalid listener" unless ref $listener; + + delete $listeners{refaddr($listener)}; +} - return $ref; - } +sub Monitor { + my ($self,$code) = @_; + + my $data = IMPL::Profiler::Memory::Data->new(); + + $data->Monitor($code); + + return $data; } -sub DumpAlive { - my ($hout) = @_; - $hout = *STDOUT unless $hout; - print $hout "Alive objects table\n"; - print $hout "-------------------\n"; - while (my ($id,$info) = each %instances) { - delete $instances{$id} and next unless $info->{WeakRef}; - print "$info->{Class} $id: $info->{WeakRef}\n"; - } +package IMPL::Profiler::Memory::Data; +use parent qw(IMPL::Object::Fields); + +use Data::Dumper(); +use Scalar::Util qw(refaddr weaken isweak); + +use fields qw( objects ); + +sub CTOR { + my $this = shift; + $this->{objects} = []; +} + +sub track { + my $i = scalar @{$_[0]->{objects}}; + $_[0]->{objects}[$i] = $_[1]; + weaken($_[0]->{objects}[$i]); +} + +sub Purge { + my $this = shift; + + return $this->{objects} = [ grep defined($_), @{$this->{objects}}]; } -sub StatClasses { - my ($hout) = @_; - $hout = *STDOUT unless $hout; - print $hout "Statistics by class\n"; - print $hout "-------------------\n"; - my %stat; - while (my ($id,$info) = each %instances) { - #$stat{$info->{Class}}{total} ++; - delete $instances{$id} and next unless $info->{WeakRef}; - $stat{$info->{Class}}{alive} ++; - } +sub Dump { + my $this = shift; + return Data::Dumper->Dump($this->{objects}); +} - print $hout "$_ $stat{$_}{alive} \n" foreach sort keys %stat; +sub isLeak { + my ($this) = @_; + $this->Purge(); + return ( scalar(@{$this->{objects}}) > 0); } -sub Clear { - undef %instances; +sub Monitor { + my ($this,$code) = @_; + + die "A reference to a subroutine is required" unless ref $code; + + IMPL::Profiler::Memory->_ConnectListener($this); + eval { + $code->(); + }; + my $err = $@; + IMPL::Profiler::Memory->_RemoveListener($this); + + die $err if $err; + + return; } + + 1;
--- a/Lib/IMPL/Test.pm Tue Apr 03 07:54:25 2012 +0400 +++ b/Lib/IMPL/Test.pm Tue Apr 03 20:08:42 2012 +0400 @@ -6,7 +6,7 @@ require Exporter; our @ISA = qw(Exporter); -our @EXPORT_OK = qw(&test &shared &failed &cmparray &skip &run_plan &assert); +our @EXPORT_OK = qw(&test &shared &failed &cmparray &skip &run_plan &assert &GetCallerSourceLine); require IMPL::Test::Unit; require IMPL::Test::Plan; @@ -72,6 +72,11 @@ return "line $line: $text"; } +sub GetCallerSourceLine { + my $line = shift || 0; + return _GetSourceLine( (caller($line + 1))[1,2] ) +} + sub run_plan { my (@units) = @_;
--- a/Lib/IMPL/Web/View/TTControl.pm Tue Apr 03 07:54:25 2012 +0400 +++ b/Lib/IMPL/Web/View/TTControl.pm Tue Apr 03 20:08:42 2012 +0400 @@ -36,6 +36,7 @@ if ( my $ctor = $template->blocks->{CTOR} ) { $context->process($ctor, { this => $this } ); + $this->templateVars('this',undef); } $this->id($name . "-" . _GetNextId()) unless $this->id; @@ -85,7 +86,7 @@ my $this = shift; - $this->nodeProperty(@_); + $this->nodeProperty($method,@_); } 1;
--- a/Lib/IMPL/Web/View/TTDocument.pm Tue Apr 03 07:54:25 2012 +0400 +++ b/Lib/IMPL/Web/View/TTDocument.pm Tue Apr 03 20:08:42 2012 +0400 @@ -47,19 +47,19 @@ if (my $factory = $this->controls->{$control}) { return $factory; } else { - +=pod my $path = $control; if ( my $template = $this->loader->template($path) ) { - my $opts = { %{$this->opts} }; - $opts->{STASH} = $this->context->stash->clone(); - - my $ctx = new Template::Context($opts); + #my $opts = { %{$this->opts} }; + #$opts->{STASH} = $this->context->stash->clone(); + + my $ctx = new Template::Context();#$opts); $factory = new IMPL::Web::View::TTFactory( typeof IMPL::Web::View::TTControl, $template, $ctx, - $opts + {} #$opts ); my @parts = split(/\/+/,$control); @@ -68,10 +68,11 @@ $this->context->stash->set([map { $_, 0 } @parts], $factory); return $factory; + } else { die new IMPL::KeyNotFoundException($control); } - +=cut } } @@ -82,7 +83,7 @@ sub Render { my ($this,$args) = @_; - my $output = $this->IMPL::Web::TTControl::Render( { document => $this } ); + my $output = $this->SUPER::Render( { document => $this } ); if ($this->layout) { $output = $this->context->include($this->layout, { content => $output } );
--- a/_test/Resources/TTView/My/Org/Panel.tt Tue Apr 03 07:54:25 2012 +0400 +++ b/_test/Resources/TTView/My/Org/Panel.tt Tue Apr 03 20:08:42 2012 +0400 @@ -5,7 +5,6 @@ dojo.require.push( dojoDefaultClass ); END; BLOCK CTOR; - controlObject = this; dojoClass = dojoDefaultClass; visualClass = this.nodeProperty('visualClass') || 'classic'; END;
--- a/_test/Resources/TTView/simple.tt Tue Apr 03 07:54:25 2012 +0400 +++ b/_test/Resources/TTView/simple.tt Tue Apr 03 20:08:42 2012 +0400 @@ -2,4 +2,4 @@ [% BLOCK CTOR; templateVar = "initialized by the constructor"; END; %] -$user - $document.title \ No newline at end of file +$user - $template.title \ No newline at end of file
--- a/_test/Test/DOM/Node.pm Tue Apr 03 07:54:25 2012 +0400 +++ b/_test/Test/DOM/Node.pm Tue Apr 03 20:08:42 2012 +0400 @@ -3,8 +3,9 @@ use warnings; use parent qw(IMPL::Test::Unit); -use IMPL::Test qw(test shared failed cmparray); +use IMPL::Test qw(test shared failed cmparray assert); use IMPL::Class::Property; +use Scalar::Util qw(weaken); require IMPL::DOM::Node; @@ -226,6 +227,13 @@ failed "Got wrong list of props", @props unless cmparray(\@props,\@expected); }; +test MemoryLeaks => sub { + my $doc = new IMPL::DOM::Document(nodeName => 'Root'); + weaken($doc); + + assert(not defined $doc); +}; + package Test::DOM::TypedNode; use parent qw(IMPL::DOM::Node); use IMPL::Class::Property;
--- a/_test/Test/Web/View.pm Tue Apr 03 07:54:25 2012 +0400 +++ b/_test/Test/Web/View.pm Tue Apr 03 20:08:42 2012 +0400 @@ -1,4 +1,5 @@ package Test::Web::View; +use IMPL::Profiler::Memory; use strict; use warnings; use utf8; @@ -7,30 +8,50 @@ __PACKAGE__->PassThroughArgs; use File::Slurp; +use Scalar::Util qw(weaken); -use IMPL::Test qw(assert test); +use IMPL::Test qw(assert test GetCallerSourceLine); use IMPL::Web::View::TTLoader(); use constant { - TTLoader => typeof IMPL::Web::View::TTLoader + TTLoader => typeof IMPL::Web::View::TTLoader, + MProfiler => 'IMPL::Profiler::Memory' }; +sub AssertMemoryLeak { + my $code = shift; + my $dump = shift; + + my $data = MProfiler->Monitor($code, sub { $_ =~ m/^IMPL::/} ); + + assert( not($data->isLeak), "Memory leak detected", GetCallerSourceLine() , @{$data->{objects}}, $dump ? $data->Dump : () ); +} + sub templatesDir { $_[0]->GetResourceDir('Resources','TTView'); } -test TTLoaderTests => sub { +sub CreateLoader { my ($this) = @_; my $loader = TTLoader->new( { INCLUDE_PATH => [ $this->templatesDir - ] + ], + INTERPOLATE => 1, + POST_CHOMP => 1, + ENCODING => 'utf-8' }, ext => '.tt', initializer => 'global.tt' ); +} + +test TTLoaderTests => sub { + my ($this) = @_; + + my $loader = $this->CreateLoader(); # test the loader to be able to find a desired resource assert( defined($loader->template('simple') ) ); @@ -47,22 +68,16 @@ # document should inherit loader's context assert( $doc->context->stash->get('user') eq 'test_user'); + + # document should not have 'this' template variable + assert( not $doc->templateVars('this') ); + + assert( $doc->context != $loader->context); # document should have an own context }; test TTDocumentTests => sub { my ($this) = @_; - my $loader = TTLoader->new( - { - INCLUDE_PATH => [ - $this->templatesDir - ], - INTERPOLATE => 1, - POST_CHOMP => 1, - ENCODING => 'utf-8' - }, - ext => '.tt', - initializer => 'global.tt' - ); + my $loader = $this->CreateLoader(); my $doc = $loader->document('simple'); @@ -70,10 +85,11 @@ assert($doc->nodeName eq 'document'); assert(not $doc->can('notexists')); # autoloaded property should be ignored - assert($doc->notexists eq ''); # nonexisting property - assert($doc->version == 10); # static metadata - assert($doc->user eq 'test_user'); # global data - assert($doc->templateVar eq 'initialized by the constructor'); # defined in CTOR block + assert(not defined $doc->notexists); # nonexisting property + assert($doc->template->version == 10); # static metadata + assert($doc->templateVars('notexists') eq ''); #nonexisting template variable + assert($doc->templateVars('user') eq 'test_user'); # global data + assert($doc->templateVars('templateVar') eq 'initialized by the constructor'); # defined in CTOR block my $text = $doc->Render(); my $expected = read_file($this->GetResourceFile('Resources','TTView.Output','simple.txt'), binmode => ':utf8'); @@ -85,18 +101,7 @@ test TTControlTests => sub { my ($this) = @_; - my $loader = TTLoader->new( - { - INCLUDE_PATH => [ - $this->templatesDir - ], - INTERPOLATE => 1, - POST_CHOMP => 1, - ENCODING => 'utf8' - }, - ext => '.tt', - initializer => 'global.tt' - ); + my $loader = $this->CreateLoader(); my $doc = $loader->document('simple'); @@ -106,22 +111,23 @@ assert(defined $factory); + assert(not $loader->context->stash->get('My.Org.Panel')); + + assert($factory->context->stash != $doc->context->stash); + assert($factory == $doc->require('My/Org/Panel'), "Control should be loaded only once"); my $ctl = $factory->new('information', { visualClass => 'simple' } ); - assert(defined $ctl); - + assert(defined $ctl); assert($ctl->nodeName eq 'information', "Created control should have a name", "Got: ".$ctl->nodeName, "Expected: information"); assert($ctl->nodeProperty('visualClass') eq 'simple'); - assert($ctl->controlObject == $ctl); - assert($factory->instances == 1); - assert($doc->context->stash->get('My.Org.Panel') == $factory); + assert($doc->templateVars('My.Org.Panel') == $factory); my $text = $ctl->Render(); my $expected = read_file($this->GetResourceFile('Resources', 'TTView.Output', 'Panel.txt'), binmode => ':utf8'); @@ -130,4 +136,27 @@ }; +test TestMemoryLeaks => sub { + my ($this) = @_; + + my $loader = $this->CreateLoader(); + $loader->document('simple'); # force loader initialization + + AssertMemoryLeak(sub { + my $doc = $loader->document('simple'); + }); + + AssertMemoryLeak(sub { + my $doc = $loader->document('simple'); + $doc->Render( { self => $doc } ); + }); + + AssertMemoryLeak(sub{ + my $doc = $loader->document('simple'); + my $factory = $doc->require('My/Org/Panel'); + #my $ctl = $doc->AppendChild($factory->new('information', { visualClass => 'complex' }) ); + }); + +}; + 1; \ No newline at end of file