Mercurial > pub > Impl

comparison lib/IMPL/Object/Abstract.pm @ 407:c6e90e02dd17 ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
renamed Lib->lib
author cin
date Fri, 04 Sep 2015 19:40:23 +0300
parents
children ee36115f6a34
comparison
equal deleted inserted replaced
406:f23fcb19d3c1 407:c6e90e02dd17
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