|
423
|
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; |
