Mercurial > pub > Impl
diff lib/IMPL/Object/_Base.pm @ 423:60c2892a577c ref20150831
working on base class system
author | cin |
---|---|
date | Mon, 02 Apr 2018 07:35:23 +0300 |
parents | |
children | 87af445663d7 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Object/_Base.pm Mon Apr 02 07:35:23 2018 +0300 @@ -0,0 +1,60 @@ +package IMPL::Object::_Base; +use strict; +use mro; + +sub _build_ctor { + my $class = shift; + + my @isa = reverse @{mro::get_linear_isa($class)}; + + +} + +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 _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; \ No newline at end of file