Mercurial > pub > Impl

comparison Lib/Common.pm @ 0:03e58a454b20

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Создан репозитарий
author Sergey
date Tue, 14 Jul 2009 12:54:37 +0400
parents
children 16ada169ca75
comparison
equal deleted inserted replaced
-1:000000000000 0:03e58a454b20
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;