|
423
|
1 package IMPL::Object::_Base;
|
|
|
2 use strict;
|
|
424
|
3 use warnings;
|
|
423
|
4 use mro;
|
|
|
5
|
|
424
|
6 sub __construct;
|
|
|
7 sub __destroy;
|
|
|
8
|
|
|
9 *__construct = _strap_ctor(__PACKAGE__);
|
|
|
10 *__destroy = _strap_dtor(__PACKAGE__);
|
|
|
11
|
|
|
12 sub DESTROY {
|
|
|
13 shift->__destroy();
|
|
|
14 }
|
|
|
15
|
|
|
16 sub _strap_ctor {
|
|
|
17 my ($class, $ctor) = @_;
|
|
|
18 no strict 'refs';
|
|
|
19 no warnings 'redefine';
|
|
423
|
20
|
|
424
|
21 return sub {
|
|
|
22 my $self = ref shift;
|
|
|
23
|
|
|
24 if ($self ne $class) {
|
|
|
25 my $t = _get_ctor($self, undef, '@_');
|
|
|
26 *{"${self}::__construct"} = _strap_ctor($self, $t);
|
|
|
27 goto &$t if $t;
|
|
|
28 } else {
|
|
|
29 goto &$ctor if $ctor;
|
|
|
30 }
|
|
|
31 };
|
|
|
32 }
|
|
|
33
|
|
|
34 sub _strap_dtor {
|
|
|
35 my ($class, $dtor) = @_;
|
|
423
|
36
|
|
424
|
37 no strict 'refs';
|
|
|
38 no warnings 'redefine';
|
|
423
|
39
|
|
424
|
40 return sub {
|
|
|
41 my $self = ref shift;
|
|
|
42
|
|
|
43 if ($self ne $class) {
|
|
|
44 my $t = _get_dtor($self);
|
|
|
45 *{"${self}::__destroy"} = _strap_dtor($self, $t);
|
|
|
46 goto &$t if $t;
|
|
|
47 } else {
|
|
|
48 goto &$dtor if $dtor;
|
|
|
49 }
|
|
|
50 };
|
|
423
|
51 }
|
|
|
52
|
|
|
53 sub _get_ctor {
|
|
|
54 my ($class, $prev, $t) = @_;
|
|
|
55 no strict 'refs';
|
|
|
56
|
|
|
57 #say "_get_ctor($class, $prev, $t)";
|
|
|
58
|
|
|
59 my $isolate = ((not defined($t)) or ($t ne '@_'));
|
|
|
60
|
|
|
61 my $ctor = $isolate ? *{"${class}::CTOR"}{CODE} : _chain_call(*{"${class}::CTOR"}{CODE}, $prev);
|
|
|
62
|
|
|
63 foreach my $base (@{"${class}::ISA"}) {
|
|
|
64 $ctor = _get_ctor($base, $ctor, exists ${"${class}::ISA"}{$base} ? ${"${class}::ISA"}{$base} : '@_');
|
|
|
65 }
|
|
|
66
|
|
|
67 if ($isolate) {
|
|
|
68 $ctor = _chain_call(_chain_params($ctor, $t), $prev);
|
|
|
69 }
|
|
|
70
|
|
|
71 return $ctor;
|
|
|
72 }
|
|
|
73
|
|
424
|
74 sub _get_dtor {
|
|
|
75 my ($class, $prev) = @_;
|
|
|
76 no strict 'refs';
|
|
|
77
|
|
|
78 my $dtor = _chain_call(*{"${class}::DTOR"}{CODE}, $prev);
|
|
|
79 $dtor = _get_dtor($_, $dtor) foreach @{"${class}::ISA"};
|
|
|
80
|
|
|
81 return $dtor;
|
|
|
82 }
|
|
|
83
|
|
423
|
84 sub _chain_call {
|
|
|
85 my ($method, $next) = @_;
|
|
|
86
|
|
|
87 return $method unless $next;
|
|
|
88 return $next unless $method;
|
|
|
89
|
|
|
90 return sub { &$method(@_); goto &$next; }
|
|
|
91 }
|
|
|
92
|
|
|
93 sub _chain_params {
|
|
|
94 my ($method, $prepare) = @_;
|
|
|
95
|
|
|
96 return unless $method;
|
|
|
97
|
|
|
98 if (not defined $prepare) {
|
|
|
99 return sub { @_ = (shift); goto &$method };
|
|
|
100 } elsif ($prepare eq '@_') {
|
|
|
101 return $method;
|
|
|
102 } elsif (ref $prepare eq 'CODE') {
|
|
|
103 return sub {
|
|
|
104 @_ = (shift, &$prepare(@_));
|
|
|
105 goto &$method;
|
|
|
106 }
|
|
|
107 }
|
|
|
108 }
|
|
|
109
|
|
|
110 1; |
