|
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__);
|
|
425
|
10 *__destroy = _strap_dtor(__PACKAGE__);
|
|
424
|
11
|
|
|
12 sub DESTROY {
|
|
|
13 shift->__destroy();
|
|
|
14 }
|
|
|
15
|
|
|
16 sub _strap_ctor {
|
|
425
|
17 my ( $class, $ctor ) = @_;
|
|
424
|
18 no strict 'refs';
|
|
|
19 no warnings 'redefine';
|
|
425
|
20
|
|
|
21 return $ctor
|
|
|
22 ? sub {
|
|
|
23 my $self = ref $_[0];
|
|
424
|
24
|
|
425
|
25 if ( $self ne $class ) {
|
|
|
26 my $t = _get_ctor( $self, undef, '@_' );
|
|
|
27 *{"${self}::__construct"} = _strap_ctor( $self, $t );
|
|
|
28 goto &$t;
|
|
|
29 }
|
|
|
30
|
|
|
31 goto &$ctor;
|
|
|
32 }
|
|
|
33 : sub {
|
|
|
34 my $self = ref $_[0];
|
|
|
35 if ( $self ne $class ) {
|
|
|
36 my $t = _get_ctor( $self, undef, '@_' );
|
|
|
37 *{"${self}::__construct"} = _strap_ctor( $self, $t );
|
|
424
|
38 goto &$t if $t;
|
|
|
39 }
|
|
425
|
40 };
|
|
424
|
41 }
|
|
|
42
|
|
|
43 sub _strap_dtor {
|
|
425
|
44 my ( $class, $dtor ) = @_;
|
|
424
|
45 no strict 'refs';
|
|
|
46 no warnings 'redefine';
|
|
425
|
47
|
|
|
48 return $dtor
|
|
|
49 ? sub {
|
|
|
50 my $self = ref $_[0];
|
|
424
|
51
|
|
425
|
52 if ( $self ne $class ) {
|
|
424
|
53 my $t = _get_dtor($self);
|
|
425
|
54 *{"${self}::__destroy"} = _strap_dtor( $self, $t );
|
|
|
55 goto &$t;
|
|
424
|
56 }
|
|
425
|
57
|
|
|
58 goto &$dtor;
|
|
|
59 }
|
|
|
60 : sub {
|
|
|
61 my $self = ref $_[0];
|
|
|
62 if ( $self ne $class ) {
|
|
|
63 my $t = _get_dtor($self);
|
|
|
64 *{"${self}::__destroy"} = _strap_dtor( $self, $t );
|
|
|
65 goto &$t if $t;
|
|
|
66 }
|
|
|
67 };
|
|
423
|
68 }
|
|
|
69
|
|
|
70 sub _get_ctor {
|
|
425
|
71 my ( $class, $prev, $t ) = @_;
|
|
423
|
72 no strict 'refs';
|
|
425
|
73
|
|
423
|
74 #say "_get_ctor($class, $prev, $t)";
|
|
425
|
75
|
|
|
76 my $isolate = ( ( not defined($t) ) or ( $t ne '@_' ) );
|
|
|
77
|
|
|
78 my $ctor =
|
|
|
79 $isolate
|
|
|
80 ? *{"${class}::CTOR"}{CODE}
|
|
|
81 : _chain_call( *{"${class}::CTOR"}{CODE}, $prev );
|
|
|
82
|
|
|
83 foreach my $base ( @{"${class}::ISA"} ) {
|
|
|
84 $ctor = _get_ctor( $base, $ctor,
|
|
|
85 exists ${"${class}::ISA"}{$base}
|
|
|
86 ? ${"${class}::ISA"}{$base}
|
|
|
87 : '@_' );
|
|
423
|
88 }
|
|
425
|
89
|
|
423
|
90 if ($isolate) {
|
|
425
|
91 $ctor = _chain_call( _chain_params( $ctor, $t ), $prev );
|
|
423
|
92 }
|
|
425
|
93
|
|
423
|
94 return $ctor;
|
|
|
95 }
|
|
|
96
|
|
424
|
97 sub _get_dtor {
|
|
425
|
98 my ( $class, $prev ) = @_;
|
|
424
|
99 no strict 'refs';
|
|
425
|
100
|
|
|
101 my $dtor = _chain_call( *{"${class}::DTOR"}{CODE}, $prev );
|
|
|
102 $dtor = _get_dtor( $_, $dtor ) foreach @{"${class}::ISA"};
|
|
|
103
|
|
424
|
104 return $dtor;
|
|
|
105 }
|
|
|
106
|
|
423
|
107 sub _chain_call {
|
|
425
|
108 my ( $method, $next ) = @_;
|
|
|
109
|
|
423
|
110 return $method unless $next;
|
|
425
|
111 return $next unless $method;
|
|
|
112
|
|
423
|
113 return sub { &$method(@_); goto &$next; }
|
|
|
114 }
|
|
|
115
|
|
|
116 sub _chain_params {
|
|
425
|
117 my ( $method, $prepare ) = @_;
|
|
|
118
|
|
423
|
119 return unless $method;
|
|
425
|
120
|
|
|
121 if ( not defined $prepare ) {
|
|
423
|
122 return sub { @_ = (shift); goto &$method };
|
|
425
|
123 }
|
|
|
124 elsif ( $prepare eq '@_' ) {
|
|
423
|
125 return $method;
|
|
425
|
126 }
|
|
|
127 elsif ( ref $prepare eq 'CODE' ) {
|
|
423
|
128 return sub {
|
|
425
|
129 @_ = ( shift, &$prepare(@_) );
|
|
423
|
130 goto &$method;
|
|
425
|
131 }
|
|
423
|
132 }
|
|
|
133 }
|
|
|
134
|
|
425
|
135 1;
|
