# HG changeset patch
# User sergey
# Date 1359465550 -14400
# Node ID ad93c9f4dd930842f90bc68606bb3e1c20a6c8ff
# Parent  47db27ed5b43d10035e19288250557774958616b
+Added support for destructors, (special method named DTOR)

diff -r 47db27ed5b43 -r ad93c9f4dd93 Lib/IMPL/Object/Abstract.pm
--- a/Lib/IMPL/Object/Abstract.pm	Mon Jan 28 17:24:37 2013 +0400
+++ b/Lib/IMPL/Object/Abstract.pm	Tue Jan 29 17:19:10 2013 +0400
@@ -63,6 +63,50 @@
     $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)};
 }
 
+sub _init_dtor {
+	my ($class) = @_;
+	
+	no strict 'refs';
+	
+	# avoid warnings for classes without destructors 
+	no warnings 'once';
+	
+	my @dtors;
+	
+	my @hierarchy = ($class);
+	my %visited;
+	
+	while(my $subclass = shift @hierarchy) {
+		if(*{"${subclass}::DTOR"}{CODE}) {
+            push @dtors, *{"${subclass}::DTOR"}{CODE};
+		}
+		
+		push @hierarchy, @{"${subclass}::ISA"};
+	}
+	
+	if (@dtors) {
+	
+		return *{"${class}::callDTOR"} = sub {
+			my ($self) = @_; 
+			my $selfClass = ref $self;
+			if ($selfClass ne $class) {
+				goto &{$selfClass->_init_dtor()};
+			} else {
+	            map $_->($self), @dtors;			
+			}
+		}
+	
+	} else {
+		return *{"${class}::callDTOR"} = sub {
+            my $self = ref $_[0];
+            
+            goto &{$self->_init_dtor()} unless $self eq $class;
+		}
+	}
+}
+
+__PACKAGE__->_init_dtor();
+
 sub toString {
     my $self = shift;
     
@@ -77,12 +121,9 @@
     0;
 }
 
-#sub DESTROY {
-#    if ($MemoryLeakProtection and $Cleanup) {
-#        my $this = shift;
-#        warn sprintf("Object leaks: %s of type %s %s",$this->can('ToString') ? $this->ToString : $this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : '');
-#    }
-#}
+sub DESTROY {
+	shift->callDTOR();
+}
 
 sub END {
     $Cleanup = 1;
diff -r 47db27ed5b43 -r ad93c9f4dd93 Lib/IMPL/Object/Disposable.pm
--- a/Lib/IMPL/Object/Disposable.pm	Mon Jan 28 17:24:37 2013 +0400
+++ b/Lib/IMPL/Object/Disposable.pm	Tue Jan 29 17:19:10 2013 +0400
@@ -9,7 +9,7 @@
     bless $this, 'IMPL::Object::Disposed';
 }
 
-sub DESTROY {
+sub DTOR {
     my ($this) = @_;
 
     warn sprintf('The object %s were marked as disposable but isn\'t disposed properly', $this->can('ToString') ? $this->ToString() : (ref $this || $this) );
diff -r 47db27ed5b43 -r ad93c9f4dd93 _test/Test/Object/Destructors.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/_test/Test/Object/Destructors.pm	Tue Jan 29 17:19:10 2013 +0400
@@ -0,0 +1,118 @@
+package Test::Object::Destructors;
+use strict;
+
+use IMPL::Test qw(test assert cmparray);
+
+use IMPL::declare {
+	base => [
+	   'IMPL::Test::Unit' => '@_'
+	]
+};
+
+{
+	package Test::Object::Destructors::Foo;
+	use IMPL::Const qw(:prop);
+	use IMPL::declare {
+		base => [
+            'IMPL::Object' => undef
+		],
+		props => [
+		    trace => PROP_RO
+		]
+	};
+	
+	sub CTOR {
+		my ($this,$trace) = @_;
+		
+		$this->trace($trace);
+	}
+	
+	sub DTOR {
+		shift->Trace("Foo");
+	}
+	
+	sub Trace {
+		my $this = shift;
+		push @{$this->trace||[]}, join ' ', @_;
+	}
+	
+	package Test::Object::Destructors::Bar;
+	use IMPL::declare {
+		base => [
+            '-Test::Object::Destructors::Foo' => '@_'
+		]
+	};
+	
+
+	sub DTOR {
+		shift->Trace("Bar");
+	}
+	
+	package Test::Object::Destructors::Boss;
+	use IMPL::declare {
+		base => [
+            '-Test::Object::Destructors::Bar' => '@_',
+            '-Test::Object::Destructors::Foo' => '@_',
+		]
+	};
+	
+	sub DTOR {
+		shift->Trace("Boss");
+	}
+}
+
+use constant {
+	Foo => 'Test::Object::Destructors::Foo',
+	Bar => 'Test::Object::Destructors::Bar',
+	Boss => 'Test::Object::Destructors::Boss'
+};
+
+test ObjectHasDestructor => sub {
+	my @expected = qw( Foo );
+    my @trace;
+    {
+       my $foo = Foo->new(\@trace);
+    };
+    assert(
+        cmparray(\@expected,\@trace),
+        "Wrong destructors sequence",
+        "expected: ",
+        join(", ",@expected),
+        "got: ",
+        join(", ", @trace)
+    );
+};
+
+test InheritanceWithDestructor => sub {
+	my @expected = qw( Bar Foo );
+    my @trace;
+	{
+	   my $bar = Bar->new(\@trace);
+	};
+	assert(
+        cmparray(\@expected,\@trace),
+        "Wrong destructors sequence",
+        "expected: ",
+        join(", ",@expected),
+        "got: ",
+        join(", ", @trace)
+    );
+};
+
+test MultipleInheritanceWithDestructor => sub {
+	my @expected = qw( Boss Bar Foo Foo );
+	my @trace;
+    {
+    	my $boss = Boss->new(\@trace);
+    };
+    assert(
+        cmparray(\@expected,\@trace),
+        "Wrong destructors sequence",
+        "expected: ",
+        join(", ",@expected),
+        "got: ",
+        join(", ", @trace)
+    );
+};
+
+1;
\ No newline at end of file
diff -r 47db27ed5b43 -r ad93c9f4dd93 _test/object.t
--- a/_test/object.t	Mon Jan 28 17:24:37 2013 +0400
+++ b/_test/object.t	Tue Jan 29 17:19:10 2013 +0400
@@ -10,6 +10,7 @@
 	Test::Class::Meta
 	Test::Class::Template
     Test::Object::Common
+    Test::Object::Destructors
     Test::Object::List
     Test::Object::Fields
 );