Mercurial > pub > Impl

comparison lib/IMPL/Object/_Base.pm @ 424:87af445663d7 ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
IMPL::Object::_Base
author cin
date Tue, 03 Apr 2018 10:54:09 +0300
parents 60c2892a577c
children c27434cdd611
comparison
equal deleted inserted replaced
423:60c2892a577c 424:87af445663d7
1 package IMPL::Object::_Base; 1 package IMPL::Object::_Base;
2 use strict; 2 use strict;
3 use warnings;
3 use mro; 4 use mro;
4 5
5 sub _build_ctor { 6 sub __construct;
6 my $class = shift; 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';
7 20
8 my @isa = reverse @{mro::get_linear_isa($class)}; 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) = @_;
9 36
37 no strict 'refs';
38 no warnings 'redefine';
10 39
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 };
11 } 51 }
12 52
13 sub _get_ctor { 53 sub _get_ctor {
14 my ($class, $prev, $t) = @_; 54 my ($class, $prev, $t) = @_;
15 no strict 'refs'; 55 no strict 'refs';
27 if ($isolate) { 67 if ($isolate) {
28 $ctor = _chain_call(_chain_params($ctor, $t), $prev); 68 $ctor = _chain_call(_chain_params($ctor, $t), $prev);
29 } 69 }
30 70
31 return $ctor; 71 return $ctor;
72 }
73
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;
32 } 82 }
33 83
34 sub _chain_call { 84 sub _chain_call {
35 my ($method, $next) = @_; 85 my ($method, $next) = @_;
36 86