|
49
|
1 package Common;
|
|
|
2 use strict;
|
|
|
3 no strict 'refs';
|
|
|
4
|
|
|
5 require Exporter;
|
|
|
6
|
|
|
7 our @ISA = qw(Exporter);
|
|
|
8 our @EXPORT = qw(&ACCESS_NONE &ACCESS_READ &ACCESS_WRITE &ACCESS_ALL &DeclareProperty &DumpCaller &PropertyList &CloneObject);
|
|
|
9
|
|
|
10 our $Debug;
|
|
|
11
|
|
|
12 $Debug = 1 if not defined $Debug;
|
|
|
13
|
|
|
14 my %ListProperties;
|
|
|
15 my %GlobalContext;
|
|
|
16
|
|
|
17 1;
|
|
|
18
|
|
|
19 sub ACCESS_NONE () { 0 }
|
|
|
20 sub ACCESS_READ () { 1 }
|
|
|
21 sub ACCESS_WRITE () { 2 }
|
|
|
22 sub ACCESS_ALL () {ACCESS_READ | ACCESS_WRITE}
|
|
|
23
|
|
|
24 sub PropertyList {
|
|
|
25 return $ListProperties{ref($_[0]) || $_[0] || caller} || {};
|
|
|
26 }
|
|
|
27
|
|
|
28 sub DeclareProperty {
|
|
|
29 my ($attrName,$accessRights,%Mutators) = @_;
|
|
|
30
|
|
|
31 my $Package = caller;
|
|
|
32 my $Method = $Package.'::'.$attrName;
|
|
|
33 my $fldName;
|
|
|
34
|
|
|
35 my $getMutator = $Mutators{'get'};
|
|
|
36 my $setMutator = $Mutators{'set'};
|
|
|
37
|
|
|
38 ($fldName = $Method) =~ s/:+/_/g;
|
|
|
39
|
|
|
40 $ListProperties{$Package} = {} if not exists $ListProperties{$Package};
|
|
|
41 $ListProperties{$Package}->{$attrName} = $fldName;
|
|
|
42
|
|
|
43 if ($Debug) {
|
|
|
44 *$Method = sub {
|
|
|
45 my $this = shift;
|
|
|
46
|
|
|
47 die new Exception( 'too many args ['.scalar(@_).'\]' , "'$Method' called from: ".DumpCaller() ) if (@_ > 1);
|
|
|
48
|
|
|
49 my $Rights = $accessRights;
|
|
|
50 $Rights = ACCESS_ALL if $Package eq caller;
|
|
|
51
|
|
|
52 if (@_){
|
|
|
53 die new Exception("access denied 'write $Method'", "'$Method' called from: ".DumpCaller()) if not $Rights & ACCESS_WRITE;
|
|
|
54 if (defined $setMutator) {
|
|
|
55 &$setMutator($this,$fldName,shift);
|
|
|
56 } else {
|
|
|
57 $this->{$fldName} = $_[0];
|
|
|
58 }
|
|
|
59
|
|
|
60 } elsif (defined wantarray) {
|
|
|
61 die new Exception("access denied 'read $Method'", "'$Method' called from: ".DumpCaller()) if not $Rights & ACCESS_READ;
|
|
|
62 if (defined $getMutator) {
|
|
|
63 &$getMutator($this,$fldName);
|
|
|
64 } else {
|
|
|
65 if (wantarray){
|
|
|
66 if(ref $this->{$fldName} eq 'ARRAY' ) {
|
|
|
67 return @{$this->{$fldName}};
|
|
|
68 } elsif (not exists $this->{$fldName}) {
|
|
|
69 return;
|
|
|
70 } else {
|
|
|
71 return $this->{$fldName};
|
|
|
72 }
|
|
|
73 } else {
|
|
|
74 return $this->{$fldName};
|
|
|
75 }
|
|
|
76 }
|
|
|
77 } else {
|
|
|
78 undef;
|
|
|
79 }
|
|
|
80 };
|
|
|
81 *$Method = \$fldName;
|
|
|
82 } else {
|
|
|
83 *$Method = sub {
|
|
|
84 my $this = shift;
|
|
|
85 #return undef if @_ > 1;
|
|
|
86 #my $Rights = $accessRights;
|
|
|
87 #$Rights = ACCESS_ALL if $Package eq caller;
|
|
|
88
|
|
|
89 if (@_){
|
|
|
90 # return undef if not $Rights & ACCESS_WRITE;
|
|
|
91 if (defined $setMutator) {
|
|
|
92 &$setMutator($this,$fldName,shift);
|
|
|
93 } else {
|
|
|
94 $this->{$fldName} = shift;
|
|
|
95 }
|
|
|
96 } elsif (defined wantarray) {
|
|
|
97 # return undef if not $Rights & ACCESS_READ;
|
|
|
98 if (defined $getMutator) {
|
|
|
99 &$getMutator($this,$fldName);
|
|
|
100 } else {
|
|
|
101 if (wantarray){
|
|
|
102 if(ref $this->{$fldName} eq 'ARRAY' ) {
|
|
|
103 return @{$this->{$fldName}};
|
|
|
104 } elsif (not defined $this->{$fldName}) {
|
|
|
105 return;
|
|
|
106 } else {
|
|
|
107 return $this->{$fldName};
|
|
|
108 }
|
|
|
109 } else {
|
|
|
110 return $this->{$fldName};
|
|
|
111 }
|
|
|
112 }
|
|
|
113 } else {
|
|
|
114 undef;
|
|
|
115 }
|
|
|
116 };
|
|
|
117 *$Method = \$fldName;
|
|
|
118 }
|
|
|
119 }
|
|
|
120
|
|
|
121 sub DumpCaller {
|
|
|
122 return join(" ",(caller($_[0]))[1,2],(caller($_[0]+1))[3]);
|
|
|
123 }
|
|
|
124
|
|
|
125 sub Owner {
|
|
|
126 return undef if not tied $_[0];
|
|
|
127 return undef if not tied($_[0])->UNIVERSAL::can('owner');
|
|
|
128 return tied($_[0])->owner();
|
|
|
129 };
|
|
|
130
|
|
|
131 sub CloneObject {
|
|
|
132 my $object = shift;
|
|
|
133 if (ref $object == undef) {
|
|
|
134 return $object;
|
|
|
135 } elsif (ref $object eq 'SCALAR') {
|
|
|
136 return \CloneObject(${$object});
|
|
|
137 } elsif (ref $object eq 'ARRAY') {
|
|
|
138 return [map{CloneObject($_)}@{$object}];
|
|
|
139 } elsif (ref $object eq 'HASH') {
|
|
|
140 my %clone;
|
|
|
141 while (my ($key,$value) = each %{$object}) {
|
|
|
142 $clone{$key} = CloneObject($value);
|
|
|
143 }
|
|
|
144 return \%clone;
|
|
|
145 } elsif (ref $object eq 'REF') {
|
|
|
146 return \CloneObject(${$object});
|
|
|
147 } else {
|
|
|
148 if ($object->can('Clone')) {
|
|
|
149 return $object->Clone();
|
|
|
150 } else {
|
|
|
151 die new Exception('Object doesn\'t supports cloning');
|
|
|
152 }
|
|
|
153 }
|
|
|
154 }
|
|
|
155
|
|
|
156 package Exception;
|
|
|
157 use base qw(IMPL::Exception);
|
|
|
158
|
|
|
159 package Persistent;
|
|
|
160 import Common;
|
|
|
161
|
|
|
162 sub newSurogate {
|
|
|
163 my $class = ref($_[0]) || $_[0];
|
|
|
164 return bless {}, $class;
|
|
|
165 }
|
|
|
166 sub load {
|
|
|
167 my ($this,$context) = @_;
|
|
|
168 die new Exception("invalid deserialization context") if ref($context) ne 'ARRAY';
|
|
|
169 die new Exception("This is not an object") if not ref $this;
|
|
|
170
|
|
|
171 my %Props = (@{$context});
|
|
|
172 foreach my $BaseClass(@{ref($this).'::ISA'}) {
|
|
|
173 while (my ($key,$value) = each %{PropertyList($BaseClass)}) {
|
|
|
174 $this->{$value} = $Props{$value} if exists $Props{$value};
|
|
|
175 }
|
|
|
176 }
|
|
|
177
|
|
|
178 while (my ($key,$value) = each %{PropertyList(ref($this))}) {
|
|
|
179 $this->{$value} = $Props{$key} if exists $Props{$key};
|
|
|
180 }
|
|
|
181 return 1;
|
|
|
182 }
|
|
|
183 sub save {
|
|
|
184 my ($this,$context) = @_;
|
|
|
185
|
|
|
186 foreach my $BaseClass(@{ref($this).'::ISA'}) {
|
|
|
187 while (my ($key,$value) = each %{PropertyList($BaseClass)}) {
|
|
|
188 $context->AddVar($value,$this->{$value});
|
|
|
189 }
|
|
|
190 }
|
|
|
191
|
|
|
192 while (my ($key,$value) = each %{PropertyList(ref($this))}) {
|
|
|
193 $context->AddVar($key,$this->{$value});
|
|
|
194 }
|
|
|
195 return 1;
|
|
|
196 }
|
|
|
197
|
|
|
198 sub restore {
|
|
|
199 my ($class,$context,$surogate) = @_;
|
|
|
200 my $this = $surogate || $class->newNewSurogate;
|
|
|
201 $this->load($context);
|
|
|
202 return $this;
|
|
|
203 }
|
|
|
204
|
|
|
205 package Object;
|
|
|
206 import Common;
|
|
|
207
|
|
|
208 sub new {
|
|
|
209 my $class = shift;
|
|
|
210 my $self = bless {}, ref($class) || $class;
|
|
|
211 $self->CTOR(@_);
|
|
|
212 return $self;
|
|
|
213 }
|
|
|
214
|
|
|
215 sub cast {
|
|
|
216 return bless {}, ref $_[0] || $_[0];
|
|
|
217 }
|
|
|
218
|
|
|
219 our %objects_count;
|
|
|
220 our %leaked_objects;
|
|
|
221
|
|
|
222 sub CTOR {
|
|
|
223 my $this= shift;
|
|
|
224 $objects_count{ref $this} ++ if $Debug;
|
|
|
225 my %args = @_ if scalar (@_) > 0;
|
|
|
226 return if scalar(@_) == 0;
|
|
|
227
|
|
|
228 warn "invalid args in CTOR. type: ".(ref $this) if scalar(@_) % 2 != 0;
|
|
|
229 my @packages = (ref($this));
|
|
|
230 my $countArgs = int(scalar(@_) / 2);
|
|
|
231 #print "Set ", join(', ',keys %args), "\n";
|
|
|
232 LOOP_PACKS: while(@packages) {
|
|
|
233 my $package = shift @packages;
|
|
|
234 #print "\t$package\n";
|
|
|
235 my $refProps = PropertyList($package);
|
|
|
236 foreach my $name (keys %{$refProps}) {
|
|
|
237 my $fld = $refProps->{$name};
|
|
|
238 if (exists $args{$name}) {
|
|
|
239 $this->{$fld} = $args{$name};
|
|
|
240 #print "\t$countArgs, $name\n";
|
|
|
241 delete $args{$name};
|
|
|
242 $countArgs --;
|
|
|
243 last LOOP_PACKS if $countArgs < 1;
|
|
|
244 } else {
|
|
|
245 #print "\t-$name ($fld)\n";
|
|
|
246 }
|
|
|
247 }
|
|
|
248 push @packages, @{$package.'::ISA'};
|
|
|
249 }
|
|
|
250 }
|
|
|
251
|
|
|
252 sub Dispose {
|
|
|
253 my $this = shift;
|
|
|
254
|
|
|
255 if ($Debug and UNIVERSAL::isa($this,'HASH')) {
|
|
|
256 my @keys = grep { $this->{$_} and ref $this->{$_} } keys %{$this};
|
|
|
257 warn "not all fields of the object were deleted\n".join("\n",@keys) if @keys;
|
|
|
258 }
|
|
|
259
|
|
|
260 bless $this,'Object::Disposed';
|
|
|
261 }
|
|
|
262
|
|
|
263 our $MemoryLeakProtection;
|
|
|
264
|
|
|
265 sub DESTROY {
|
|
|
266 if ($MemoryLeakProtection) {
|
|
|
267 my $this = shift;
|
|
|
268 warn sprintf("Object leaks: %s of type %s %s",$this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : '');
|
|
|
269 }
|
|
|
270 }
|
|
|
271
|
|
|
272 package Object::Disposed;
|
|
|
273 our $AUTOLOAD;
|
|
|
274 sub AUTOLOAD {
|
|
|
275 return if $AUTOLOAD eq __PACKAGE__.'::DESTROY';
|
|
|
276 die new Exception('Object have been disposed',$AUTOLOAD);
|
|
|
277 }
|
|
|
278
|
|
|
279 END {
|
|
|
280 $MemoryLeakProtection = 0 if not $Debug;
|
|
|
281 }
|
|
|
282 1;
|
