Mercurial > pub > Impl
diff Lib/IMPL/Object.pm @ 2:78cd38551534
in develop
author | Sergey |
---|---|
date | Mon, 10 Aug 2009 17:39:08 +0400 |
parents | 03e58a454b20 |
children | e59f44f75f20 |
line wrap: on
line diff
--- a/Lib/IMPL/Object.pm Fri Jul 17 13:30:46 2009 +0400 +++ b/Lib/IMPL/Object.pm Mon Aug 10 17:39:08 2009 +0400 @@ -1,123 +1,18 @@ 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)}; -} +use base qw(IMPL::Object::Abstract); 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 { +sub new { 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'}; + my $self = bless {}, ref($class) || $class; + $self->callCTOR(@_); + + $self; } =pod @@ -173,15 +68,32 @@ # # Foo: Mazzi # Bar: Fugi -# Foo: # Bar: # Composite: Hello World! =h1 Description -Базовый класс для объектов. Реализует множественное наследование - +Базовый класс для объектов, основанных на хеше. =h1 Members + +=level 4 + +=item operator C<new>(@args) + +Создает экземпляр объекта и вызывает конструктор с параметрами @args. + +=item operator C<surrogate>() + +Создает неинициализированный экземпляр объекта. + +=back + +=р1 Cavearts + +Нужно заметить, что директива C<use base> работает не совсем прозрачно, если в нашем примере +класс C<Composite> наследуется от C<Baz>, а затем C<Foo>, то наследование от +C<Foo> не произойдет поскольку он уже имеется в C<Baz>. Вот не задача:) + =cut 1; \ No newline at end of file