annotate Lib/Common.pm @ 29:37160f7c8edb

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