annotate lib/IMPL/Object/Abstract.pm @ 411:ee36115f6a34 ref20150831

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