|
407
|
1 package IMPL::Object::Abstract;
|
|
|
2 use strict;
|
|
|
3 use warnings;
|
|
|
4
|
|
|
5 use parent qw(IMPL::Class::Meta);
|
|
|
6 use Carp qw(croak);
|
|
|
7
|
|
|
8 our $MemoryLeakProtection;
|
|
|
9 my $Cleanup = 0;
|
|
|
10
|
|
|
11 my %cacheCTOR;
|
|
|
12
|
|
|
13 my $t = 0;
|
|
|
14 sub cache_ctor {
|
|
|
15 my $class = shift;
|
|
|
16
|
|
|
17 no strict 'refs';
|
|
|
18 my @sequence;
|
|
|
19
|
|
|
20 my $refCTORS = *{"${class}::CTOR"}{HASH};
|
|
|
21
|
|
|
22 foreach my $super ( @{"${class}::ISA"} ) {
|
|
|
23 my $superSequence = $cacheCTOR{$super} || cache_ctor($super);
|
|
|
24
|
|
|
25 my $mapper = $refCTORS ? $refCTORS->{$super} : undef;
|
|
|
26 if (ref $mapper eq 'CODE') {
|
|
|
27 if ($mapper == *_pass_through_mapper{CODE}) {
|
|
|
28 push @sequence,@$superSequence;
|
|
|
29 } else {
|
|
|
30 push @sequence, sub {
|
|
|
31 my $this = shift;
|
|
|
32 $this->$_($mapper->(@_)) foreach @$superSequence;
|
|
|
33 } if @$superSequence;
|
|
|
34 }
|
|
|
35 } elsif ($mapper and not ref $mapper and $mapper eq '@_') {
|
|
|
36 push @sequence,@$superSequence;
|
|
|
37 } else {
|
|
|
38 warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper;
|
|
|
39 push @sequence, sub {
|
|
|
40 my $this = shift;
|
|
|
41 $this->$_() foreach @$superSequence;
|
|
|
42 } if @$superSequence;
|
|
|
43 }
|
|
|
44 }
|
|
|
45
|
|
|
46 push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE};
|
|
|
47
|
|
|
48 $cacheCTOR{$class} = \@sequence;
|
|
|
49 return \@sequence;
|
|
|
50 }
|
|
|
51
|
|
|
52 sub dump_ctor {
|
|
|
53 my ($self) = @_;
|
|
|
54 $self = ref $self || $self;
|
|
|
55
|
|
|
56 warn "dumping $self .ctor";
|
|
|
57 warn "$_" foreach @{$cacheCTOR{$self}||[]};
|
|
|
58 }
|
|
|
59
|
|
|
60 sub callCTOR {
|
|
|
61 my $self = shift;
|
|
|
62 my $class = ref $self;
|
|
|
63
|
|
|
64 $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)};
|
|
|
65 }
|
|
|
66
|
|
|
67 sub _init_dtor {
|
|
|
68 my ($class) = @_;
|
|
|
69
|
|
|
70 no strict 'refs';
|
|
|
71
|
|
|
72 # avoid warnings for classes without destructors
|
|
|
73 no warnings 'once';
|
|
|
74
|
|
|
75 my @dtors;
|
|
|
76
|
|
|
77 my @hierarchy = ($class);
|
|
|
78 my %visited;
|
|
|
79
|
|
|
80 while(my $subclass = shift @hierarchy) {
|
|
|
81 if(*{"${subclass}::DTOR"}{CODE}) {
|
|
|
82 push @dtors, *{"${subclass}::DTOR"}{CODE};
|
|
|
83 }
|
|
|
84
|
|
|
85 push @hierarchy, @{"${subclass}::ISA"};
|
|
|
86 }
|
|
|
87
|
|
|
88 if (@dtors) {
|
|
|
89
|
|
|
90 return *{"${class}::callDTOR"} = sub {
|
|
|
91 my ($self) = @_;
|
|
|
92 my $selfClass = ref $self;
|
|
|
93 if ($selfClass ne $class) {
|
|
|
94 goto &{$selfClass->_init_dtor()};
|
|
|
95 } else {
|
|
|
96 map $_->($self), @dtors;
|
|
|
97 }
|
|
|
98 }
|
|
|
99
|
|
|
100 } else {
|
|
|
101 return *{"${class}::callDTOR"} = sub {
|
|
|
102 my $self = ref $_[0];
|
|
|
103
|
|
|
104 goto &{$self->_init_dtor()} unless $self eq $class;
|
|
|
105 }
|
|
|
106 }
|
|
|
107 }
|
|
|
108
|
|
|
109 __PACKAGE__->_init_dtor();
|
|
|
110
|
|
|
111 sub toString {
|
|
|
112 my $self = shift;
|
|
|
113
|
|
|
114 return (ref $self || $self);
|
|
|
115 }
|
|
|
116
|
|
|
117 sub _typeof {
|
|
|
118 ref $_[0] || $_[0];
|
|
|
119 }
|
|
|
120
|
|
|
121 sub isDisposed {
|
|
|
122 0;
|
|
|
123 }
|
|
|
124
|
|
|
125 sub DESTROY {
|
|
|
126 shift->callDTOR();
|
|
|
127 }
|
|
|
128
|
|
|
129 sub END {
|
|
|
130 $Cleanup = 1;
|
|
|
131 }
|
|
|
132
|
|
|
133 sub _pass_through_mapper {
|
|
|
134 @_;
|
|
|
135 }
|
|
|
136
|
|
|
137 sub PassArgs {
|
|
|
138 \&_pass_through_mapper;
|
|
|
139 }
|
|
|
140
|
|
|
141 sub PassThroughArgs {
|
|
|
142 my $class = shift;
|
|
|
143 $class = ref $class || $class;
|
|
|
144 no strict 'refs';
|
|
|
145 no warnings 'once';
|
|
|
146 ${"${class}::CTOR"}{$_} = \&_pass_through_mapper foreach @{"${class}::ISA"};
|
|
|
147 }
|
|
|
148
|
|
|
149 package self;
|
|
|
150
|
|
|
151 our $AUTOLOAD;
|
|
|
152 sub AUTOLOAD {
|
|
|
153 goto &{caller(). substr $AUTOLOAD,4};
|
|
|
154 }
|
|
|
155
|
|
|
156 package supercall;
|
|
|
157
|
|
|
158 our $AUTOLOAD;
|
|
|
159 sub AUTOLOAD {
|
|
|
160 my $sub;
|
|
|
161 my $methodName = substr $AUTOLOAD,9;
|
|
|
162 no strict 'refs';
|
|
|
163 $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'};
|
|
|
164 }
|
|
|
165
|
|
|
166 1;
|
|
|
167
|
|
|
168 __END__
|
|
|
169
|
|
|
170 =pod
|
|
|
171 =head1 SYNOPSIS
|
|
|
172
|
|
|
173 package MyBaseObject;
|
|
|
174 use parent qw(IMPL::Object::Abstract);
|
|
|
175
|
|
|
176 sub new {
|
|
|
177 # own implementation of the new opeator
|
|
|
178 }
|
|
|
179
|
|
|
180 sub surrogate {
|
|
|
181 # own implementation of the surrogate operator
|
|
|
182 }
|
|
|
183
|
|
|
184 =head1 DESCRIPTION
|
|
|
185
|
|
|
186 Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов
|
|
|
187 создания экземпляров.
|
|
|
188
|
|
|
189 =cut
|
