diff lib/IMPL/Object/_Base.pm @ 424:87af445663d7 ref20150831

IMPL::Object::_Base
author cin
date Tue, 03 Apr 2018 10:54:09 +0300
parents 60c2892a577c
children c27434cdd611
line wrap: on
line diff
--- a/lib/IMPL/Object/_Base.pm	Mon Apr 02 07:35:23 2018 +0300
+++ b/lib/IMPL/Object/_Base.pm	Tue Apr 03 10:54:09 2018 +0300
@@ -1,13 +1,53 @@
 package IMPL::Object::_Base;
 use strict;
+use warnings;
 use mro;
 
-sub _build_ctor {
-	my $class = shift;
+sub __construct;
+sub __destroy;
+
+*__construct = _strap_ctor(__PACKAGE__);
+*__destroy = _strap_dtor(__PACKAGE__);
+
+sub DESTROY {
+	shift->__destroy();
+}
+
+sub _strap_ctor {
+	my ($class, $ctor) = @_;
+	no strict 'refs';
+	no warnings 'redefine';
 	
-	my @isa = reverse @{mro::get_linear_isa($class)};
+	return sub {
+		my $self = ref shift;
+		
+		if ($self ne $class) {
+			my $t = _get_ctor($self,  undef, '@_');
+			*{"${self}::__construct"} = _strap_ctor($self, $t);
+			goto &$t if $t;
+		} else {
+			goto &$ctor if $ctor;
+		}
+	};
+}
+
+sub _strap_dtor {
+	my ($class, $dtor) = @_;
 	
+	no strict 'refs';
+	no warnings 'redefine';
 	
+	return sub {
+		my $self = ref shift;
+		
+		if ($self ne $class) {
+			my $t = _get_dtor($self);
+			*{"${self}::__destroy"} = _strap_dtor($self, $t);
+			goto &$t if $t;  
+		} else {
+			goto &$dtor if $dtor;
+		}
+	};
 }
 
 sub _get_ctor {
@@ -31,6 +71,16 @@
 	return $ctor;
 }
 
+sub _get_dtor {
+	my ($class, $prev) = @_;
+	no strict 'refs';
+	
+	my $dtor = _chain_call(*{"${class}::DTOR"}{CODE}, $prev);
+	$dtor = _get_dtor($_, $dtor) foreach @{"${class}::ISA"};
+	
+	return $dtor;
+}
+
 sub _chain_call {
 	my ($method, $next) = @_;