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

use base qw(IMPL::Class::Meta);

our $MemoryLeakProtection;
my $Cleanup = 0;
our $Debug;
our %leaked_objects;

my %cacheCTOR;


sub new {
    my $class = shift;
    my $self = bless {}, ref($class) || $class;
    
    $self->$_(@_) foreach @{$cacheCTOR{ref $self} || cache_ctor(ref $self)};
  
    $self;
}
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_throgh_mapper{CODE}) {
		push @sequence,@$superSequence;
	    } else {
		push @sequence, sub {
		    my $this = shift;
		    $this->$_($mapper->(@_)) foreach @$superSequence;
		};
	    }
	} else {
	    warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper;
	    push @sequence, sub {
		my $this = shift;
		$this->$_() foreach @$superSequence;
	    };
	}
    }
    
    push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE};
    
    $cacheCTOR{$class} = \@sequence;
    return \@sequence;
}

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

    $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)};
}

sub surrogate {
    bless {}, ref $_[0] || $_[0];
}

sub superCTOR {
    my $this = shift;

    warn "The mehod is deprecated, at " . caller;
}

sub toString {
    my $self = shift;
    
    return (ref $self || $self);
}

sub DESTROY {
    if ($MemoryLeakProtection and $Cleanup) {
        my $this = shift;
        warn sprintf("Object leaks: %s of type %s %s",$this->can('ToString') ? $this->ToString : $this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : '');
    }
}

sub END {
    $Cleanup = 1;
    $MemoryLeakProtection = 0 unless $Debug;
}

sub _pass_throgh_mapper {
    @_;
}

sub PassThroughArgs {
    my $class = shift;
    $class = ref $class || $class;
    no strict 'refs';
    no warnings 'once';
    ${"${class}::CTOR"}{$_} = \&_pass_throgh_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,11;
    no strict 'refs';
    $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'};
}

=pod
=h1 SYNOPSIS

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

sub new {
    # own implementation of the new opeator
}

sub surrogate {
    # own implementation of the surrogate operator
}

=h1 DESCRIPTION

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


1;


1;