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 $ctor
	  ? sub {
		my $self = ref $_[0];
		
		if ( $self ne $class ) {
			my $t = _get_ctor( $self, undef, '@_' );
			*{"${self}::__construct"} = _strap_ctor( $self, $t );
			goto &$t;
		}

		goto &$ctor;
	  }
	  : sub {
		my $self = ref $_[0];
		if ( $self ne $class ) {
			my $t = _get_ctor( $self, undef, '@_' );
			*{"${self}::__construct"} = _strap_ctor( $self, $t );
			goto &$t if $t;
		}
	  };
}

sub _strap_dtor {
	my ( $class, $dtor ) = @_;
	no strict 'refs';
	no warnings 'redefine';

	return $dtor
	  ? sub {
		my $self = ref $_[0];
		
		if ( $self ne $class ) {
			my $t = _get_dtor($self);
			*{"${self}::__destroy"} = _strap_dtor( $self, $t );
			goto &$t;
		}

		goto &$dtor;
	  }
	  : sub {
		my $self = ref $_[0];
		if ( $self ne $class ) {
			my $t = _get_dtor($self);
			*{"${self}::__destroy"} = _strap_dtor( $self, $t );
			goto &$t if $t;
		}
	  };
}

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;