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