|
1
|
1 package IMPL::Object::Abstract;
|
|
|
2 use strict;
|
|
|
3 use warnings;
|
|
|
4 package IMPL::Object;
|
|
|
5 use strict;
|
|
|
6
|
|
|
7 use base qw(IMPL::Class::Meta);
|
|
|
8
|
|
|
9 our $MemoryLeakProtection;
|
|
|
10 my $Cleanup = 0;
|
|
|
11 our $Debug;
|
|
|
12 our %leaked_objects;
|
|
|
13
|
|
|
14 my %cacheCTOR;
|
|
|
15
|
|
|
16
|
|
|
17 sub new {
|
|
|
18 my $class = shift;
|
|
|
19 my $self = bless {}, ref($class) || $class;
|
|
|
20
|
|
|
21 $self->$_(@_) foreach @{$cacheCTOR{ref $self} || cache_ctor(ref $self)};
|
|
|
22
|
|
|
23 $self;
|
|
|
24 }
|
|
|
25 my $t = 0;
|
|
|
26 sub cache_ctor {
|
|
|
27 my $class = shift;
|
|
|
28
|
|
|
29 no strict 'refs';
|
|
|
30 my @sequence;
|
|
|
31
|
|
|
32 my $refCTORS = *{"${class}::CTOR"}{HASH};
|
|
|
33
|
|
|
34 foreach my $super ( @{"${class}::ISA"} ) {
|
|
|
35 my $superSequence = $cacheCTOR{$super} || cache_ctor($super);
|
|
|
36
|
|
|
37 my $mapper = $refCTORS ? $refCTORS->{$super} : undef;
|
|
|
38 if (ref $mapper eq 'CODE') {
|
|
|
39 if ($mapper == *_pass_throgh_mapper{CODE}) {
|
|
|
40 push @sequence,@$superSequence;
|
|
|
41 } else {
|
|
|
42 push @sequence, sub {
|
|
|
43 my $this = shift;
|
|
|
44 $this->$_($mapper->(@_)) foreach @$superSequence;
|
|
|
45 };
|
|
|
46 }
|
|
|
47 } else {
|
|
|
48 warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper;
|
|
|
49 push @sequence, sub {
|
|
|
50 my $this = shift;
|
|
|
51 $this->$_() foreach @$superSequence;
|
|
|
52 };
|
|
|
53 }
|
|
|
54 }
|
|
|
55
|
|
|
56 push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE};
|
|
|
57
|
|
|
58 $cacheCTOR{$class} = \@sequence;
|
|
|
59 return \@sequence;
|
|
|
60 }
|
|
|
61
|
|
|
62 sub callCTOR {
|
|
|
63 my $self = shift;
|
|
|
64 my $class = ref $self;
|
|
|
65
|
|
|
66 $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)};
|
|
|
67 }
|
|
|
68
|
|
|
69 sub surrogate {
|
|
|
70 bless {}, ref $_[0] || $_[0];
|
|
|
71 }
|
|
|
72
|
|
|
73 sub superCTOR {
|
|
|
74 my $this = shift;
|
|
|
75
|
|
|
76 warn "The mehod is deprecated, at " . caller;
|
|
|
77 }
|
|
|
78
|
|
|
79 sub toString {
|
|
|
80 my $self = shift;
|
|
|
81
|
|
|
82 return (ref $self || $self);
|
|
|
83 }
|
|
|
84
|
|
|
85 sub DESTROY {
|
|
|
86 if ($MemoryLeakProtection and $Cleanup) {
|
|
|
87 my $this = shift;
|
|
|
88 warn sprintf("Object leaks: %s of type %s %s",$this->can('ToString') ? $this->ToString : $this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : '');
|
|
|
89 }
|
|
|
90 }
|
|
|
91
|
|
|
92 sub END {
|
|
|
93 $Cleanup = 1;
|
|
|
94 $MemoryLeakProtection = 0 unless $Debug;
|
|
|
95 }
|
|
|
96
|
|
|
97 sub _pass_throgh_mapper {
|
|
|
98 @_;
|
|
|
99 }
|
|
|
100
|
|
|
101 sub PassThroughArgs {
|
|
|
102 my $class = shift;
|
|
|
103 $class = ref $class || $class;
|
|
|
104 no strict 'refs';
|
|
|
105 no warnings 'once';
|
|
|
106 ${"${class}::CTOR"}{$_} = \&_pass_throgh_mapper foreach @{"${class}::ISA"};
|
|
|
107 }
|
|
|
108
|
|
|
109 package self;
|
|
|
110
|
|
|
111 our $AUTOLOAD;
|
|
|
112 sub AUTOLOAD {
|
|
|
113 goto &{caller(). substr $AUTOLOAD,4};
|
|
|
114 }
|
|
|
115
|
|
|
116 package supercall;
|
|
|
117
|
|
|
118 our $AUTOLOAD;
|
|
|
119 sub AUTOLOAD {
|
|
|
120 my $sub;
|
|
|
121 my $methodName = substr $AUTOLOAD,11;
|
|
|
122 no strict 'refs';
|
|
|
123 $sub = $_->can($methodName) and $sub->(@_) foreach @{caller().'::ISA'};
|
|
|
124 }
|
|
|
125
|
|
|
126 =pod
|
|
|
127 =h1 SYNOPSIS
|
|
|
128
|
|
|
129 package MyBaseObject;
|
|
|
130 use base qw(IMPL::Object::Abstract);
|
|
|
131
|
|
|
132 sub new {
|
|
|
133 # own implementation of the new opeator
|
|
|
134 }
|
|
|
135
|
|
|
136 sub surrogate {
|
|
|
137 # own implementation of the surrogate operator
|
|
|
138 }
|
|
|
139
|
|
|
140 =h1 DESCRIPTION
|
|
|
141
|
|
|
142 Реализация механизма вызова конструкторов и других вспомогательных вещей, кроме операторов
|
|
|
143 создания экземпляров.
|
|
|
144
|
|
|
145
|
|
|
146 1;
|
|
|
147
|
|
|
148
|
|
|
149 1;
|
