Mercurial > pub > Impl

comparison lib/IMPL/Object/_Base.pm @ 423:60c2892a577c ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
working on base class system
author cin
date Mon, 02 Apr 2018 07:35:23 +0300
parents
children 87af445663d7
comparison
equal deleted inserted replaced
422:b0481c071bea 423:60c2892a577c
1 package IMPL::Object::_Base;
2 use strict;
3 use mro;
4
5 sub _build_ctor {
6 my $class = shift;
7
8 my @isa = reverse @{mro::get_linear_isa($class)};
9
10
11 }
12
13 sub _get_ctor {
14 my ($class, $prev, $t) = @_;
15 no strict 'refs';
16
17 #say "_get_ctor($class, $prev, $t)";
18
19 my $isolate = ((not defined($t)) or ($t ne '@_'));
20
21 my $ctor = $isolate ? *{"${class}::CTOR"}{CODE} : _chain_call(*{"${class}::CTOR"}{CODE}, $prev);
22
23 foreach my $base (@{"${class}::ISA"}) {
24 $ctor = _get_ctor($base, $ctor, exists ${"${class}::ISA"}{$base} ? ${"${class}::ISA"}{$base} : '@_');
25 }
26
27 if ($isolate) {
28 $ctor = _chain_call(_chain_params($ctor, $t), $prev);
29 }
30
31 return $ctor;
32 }
33
34 sub _chain_call {
35 my ($method, $next) = @_;
36
37 return $method unless $next;
38 return $next unless $method;
39
40 return sub { &$method(@_); goto &$next; }
41 }
42
43 sub _chain_params {
44 my ($method, $prepare) = @_;
45
46 return unless $method;
47
48 if (not defined $prepare) {
49 return sub { @_ = (shift); goto &$method };
50 } elsif ($prepare eq '@_') {
51 return $method;
52 } elsif (ref $prepare eq 'CODE') {
53 return sub {
54 @_ = (shift, &$prepare(@_));
55 goto &$method;
56 }
57 }
58 }
59
60 1;