# HG changeset patch
# User cin
# Date 1333469322 -14400
# Node ID 029c9610528c9eacf0ec2dec350608edd56f9ab3
# Parent  927653d01f4f29fe811b6bf838d4037cc452024f
Memory leak tests in IMPL::Web::View

diff -r 927653d01f4f -r 029c9610528c Lib/IMPL/DOM/Node.pm
--- 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
diff -r 927653d01f4f -r 029c9610528c Lib/IMPL/Profiler/Memory.pm
--- 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;
diff -r 927653d01f4f -r 029c9610528c Lib/IMPL/Test.pm
--- 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) = @_;
 	
diff -r 927653d01f4f -r 029c9610528c Lib/IMPL/Web/View/TTControl.pm
--- 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;
diff -r 927653d01f4f -r 029c9610528c Lib/IMPL/Web/View/TTDocument.pm
--- 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 } );
diff -r 927653d01f4f -r 029c9610528c _test/Resources/TTView/My/Org/Panel.tt
--- 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;
diff -r 927653d01f4f -r 029c9610528c _test/Resources/TTView/simple.tt
--- 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
diff -r 927653d01f4f -r 029c9610528c _test/Test/DOM/Node.pm
--- 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;
diff -r 927653d01f4f -r 029c9610528c _test/Test/Web/View.pm
--- 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
diff -r 927653d01f4f -r 029c9610528c _test/Web.t
--- a/_test/Web.t	Tue Apr 03 07:54:25 2012 +0400
+++ b/_test/Web.t	Tue Apr 03 20:08:42 2012 +0400
@@ -4,6 +4,7 @@
 use lib '.';
 use utf8;
 
+use IMPL::Profiler::Memory;
 use IMPL::Test qw(run_plan);