package IMPL::Object::Abstract;
use strict;
use warnings;

use parent qw(IMPL::Class::Meta);
use Carp qw(croak);

our $MemoryLeakProtection;
my $Cleanup = 0;

my %cacheCTOR;

my $t = 0;
sub cache_ctor {
    my $class = shift;
    
    no strict 'refs';
    my @sequence;
    
    my $refCTORS = *{"${class}::CTOR"}{HASH};
      
    foreach my $super ( @{"${class}::ISA"} ) {
        my $superSequence = $cacheCTOR{$super} || cache_ctor($super);
        
        my $mapper = $refCTORS ? $refCTORS->{$super} : undef;
        if (ref $mapper eq 'CODE') {
            if ($mapper == *_pass_through_mapper{CODE}) {
                push @sequence,@$superSequence;
            } else {
                push @sequence, sub {
                    my $this = shift;
                    $this->$_($mapper->(@_)) foreach @$superSequence;
                } if @$superSequence;
            }
        } elsif ($mapper and not ref $mapper and $mapper eq '@_') {
        	push @sequence,@$superSequence;
        } else {
            warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper;
            push @sequence, sub {
                my $this = shift;
                $this->$_() foreach @$superSequence;
            } if @$superSequence;
        }
    }
    
    push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE};
    
    $cacheCTOR{$class} = \@sequence;
    return \@sequence;
}

sub dump_ctor {
    my ($self) = @_;
    $self = ref $self || $self;
    
    warn "dumping $self .ctor";
    warn "$_" foreach @{$cacheCTOR{$self}||[]};
}

sub callCTOR {
    my $self = shift;
    my $class = ref $self;

    $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;
    
    return (ref $self || $self);
}

sub _typeof {
    ref $_[0] || $_[0];
}

sub isDisposed {
    0;
}

sub DESTROY {
	shift->callDTOR();
}

sub END {
    $Cleanup = 1;
}

sub _pass_through_mapper {
    @_;
}

sub PassArgs {
    \&_pass_through_mapper;
}

sub PassThroughArgs {
    my $class = shift;
    $class = ref $class || $class;
    no strict 'refs';
    no warnings 'once';
    ${"${class}::CTOR"}{$_} = \&_pass_through_mapper foreach @{"${class}::ISA"};
}

package self;

our $AUTOLOAD;
sub AUTOLOAD {
    goto &{caller(). substr $AUTOLOAD,4};
}

package supercall;

our $AUTOLOAD;
sub AUTOLOAD {
    my $sub;
    my $methodName = substr $AUTOLOAD,9;
    no strict 'refs';
    $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'};
}

1;

__END__

=pod
=head1 SYNOPSIS

package MyBaseObject;
use parent qw(IMPL::Object::Abstract);

sub new {
    # own implementation of the new opeator
}

sub surrogate {
    # own implementation of the surrogate operator
}

=head1 DESCRIPTION

Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов
создания экземпляров.

=cut