Mercurial > pub > Impl
view Lib/IMPL/Object/Abstract.pm @ 310:0a9d51cf6dfd
*TTView: refactoring, document supports custom classes, layouts are become controls
author | sergey |
---|---|
date | Fri, 19 Apr 2013 16:39:01 +0400 |
parents | c6d0f889ef87 |
children | 97628101b765 |
line wrap: on
line source
package IMPL::Object::Abstract; use strict; use warnings; use parent qw(IMPL::Class::Meta); 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,6}; } package supercall; our $AUTOLOAD; sub AUTOLOAD { my $sub; my $methodName = substr $AUTOLOAD,11; 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