package IMPL::Object::_Base;
use strict;
use warnings;
use mro;

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';
	
	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 {
	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 _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) = @_;
	
	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;
		}
	}
}

1;