# HG changeset patch
# User cin
# Date 1522742049 -10800
# Node ID 87af445663d7f6ba8d041121fee67a92d0e17fe5
# Parent  60c2892a577cc9e623af545dc24e6b4deab20326
IMPL::Object::_Base

diff -r 60c2892a577c -r 87af445663d7 _test/temp.pl
--- a/_test/temp.pl	Mon Apr 02 07:35:23 2018 +0300
+++ b/_test/temp.pl	Tue Apr 03 10:54:09 2018 +0300
@@ -8,121 +8,45 @@
 use Data::Dumper;
 use URI;
 
-#my $method = _get_ctor("Box", undef, '@_');
-
-_invoke_ctor("main","x","y","z");
-_invoke_ctor("main","x","y","z");
+package Bar;
+use base qw(IMPL::Object);
 
-sub _invoke_ctor {
-	my ($self) = @_;
-	no strict 'refs';
-	no warnings 'redefine';
-	
-	my $method = _get_ctor("Box", undef, '@_');
-	
-	*{"${self}::_invoke_ctor"} = $method;
-	
-	goto &$method;
+sub CTOR {
 }
 
-sub _get_ctor {
-	my ($class, $prev, $t) = @_;
-	no strict 'refs';
-	
-	#say "_get_ctor($class, $prev, $t)";
-	
-	my $isolate = ((not defined($t)) or ($t ne '@_'));  
-	
-	my $ctor = $isolate ? *{"${class}::CTOR"}{CODE} : _chain_call(*{"${class}::CTOR"}{CODE}, $prev); 
-	
-	foreach my $base (@{"${class}::ISA"}) {
-		$ctor = _get_ctor($base, $ctor, exists ${"${class}::ISA"}{$base} ? ${"${class}::ISA"}{$base} : '@_');
-	}
-	
-	if ($isolate) {
-		$ctor = _chain_call(_chain_params($ctor, $t), $prev);
-	}
-	
-	return $ctor;
-}
-
-sub _chain_call {
-	my ($method, $next) = @_;
-	
-	return $method unless $next;
-	return $next unless $method;
-	
-	return sub { &$method(@_); goto &$next; }
-}
-
-sub _chain_params {
-	my ($method, $prepare) = @_;
-	
-	return unless $method;
-	
-	if (not defined $prepare) {
-		return sub { @_ = (shift); goto &$method };
-	} elsif ($prepare eq '@_') {
-		return $method;
-	} elsif (ref $prepare eq 'CODE') {
-		return sub {
-			@_ = (shift, &$prepare(@_));
-			goto &$method;
-		}
-	}
-}
-
-package Obj;
+package Bar2;
+use base qw(Bar);
 
 sub CTOR {
-	say "Obj ", join (',', @_);
-	say Carp::longmess();
 }
 
 package Foo;
-
-BEGIN {
-	our @ISA = qw(Obj);
-	our %ISA = (
-		Obj => sub { "hi" }
-	);
-}
+use base qw(IMPL::Object::_Base);
 
-sub CTOR {
-	say "Foo ", join (',', @_);
-}
-
-package Bar;
-
-BEGIN {
-	our @ISA = qw(Foo);
-	our %ISA = (
-		Foo => undef
-	);
+sub new {
+	my $instance = bless {}, shift;
+	$instance->__construct();
+	return $instance;
 }
 
 sub CTOR {
-	say "Bar ", join(',', @_);
-}
-
-package Baz;
-
-sub CTOR {
-	say "Baz ", join(',', @_);
 }
 
-package Box;
+package Foo2;
+use base qw(Foo);
+
+sub CTOR {
+	
+} 
 
-BEGIN {
-	our @ISA = qw(Bar Baz);
-	our %ISA = (
-		Bar => sub { shift . "~Box->Bar", @_; },
-		Baz => sub { shift . "~Box->Baz", @_; }
-	);
+package main;
+
+my $t = [gettimeofday];
+
+for(my $i=0; $i <1000000; $i++) {
+	my $v = new Bar2;
 }
 
-sub CTOR {
-	say "Box ", join(',', @_);
-}
+say tv_interval($t);
 
 1;
diff -r 60c2892a577c -r 87af445663d7 lib/IMPL/Object/_Base.pm
--- 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) = @_;