Mercurial > pub > Impl

comparison lib/IMPL/Object/_Base.pm @ 427:09e0086a82a7 ref20150831 tip

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