|
49
|
1 package IMPL::Serialization;
|
|
|
2 use strict;
|
|
0
|
3
|
|
|
4 # 20060222
|
|
49
|
5 # ������ ��� ������������ �������� ������
|
|
|
6 # (�) Sourcer, cin.sourcer@gmail.com
|
|
0
|
7 # revision 3 (20090517)
|
|
|
8
|
|
|
9
|
|
|
10 package IMPL::Serialization::Context;
|
|
|
11 use base qw(IMPL::Object);
|
|
|
12
|
|
|
13 use IMPL::Class::Property;
|
|
|
14 use IMPL::Class::Property::Direct;
|
|
|
15 use IMPL::Exception;
|
|
|
16 use Scalar::Util qw(refaddr);
|
|
|
17
|
|
|
18 BEGIN {
|
|
49
|
19 private _direct property ObjectWriter => prop_all; # ������, ������������ ������ � �����
|
|
|
20 private _direct property Context => prop_all; # �������� (������� ������� ��� �������������, �� ��������������)
|
|
|
21 private _direct property NextID => prop_all;# ��������� ������������� ��� �������
|
|
0
|
22
|
|
49
|
23 # ���������, ������� �����, ��� ��������������� ������������ ����. ������ ����������
|
|
|
24 # �������� ������ �� IMPL::Serialization::Context, ������ ���������� ������ �� ������
|
|
0
|
25 public _direct property Serializer => prop_all;
|
|
|
26
|
|
49
|
27 private _direct property State => prop_all; # ��������� ��������� ������������
|
|
0
|
28 }
|
|
|
29
|
|
49
|
30 # �������� ������, �.�. ������� ������ �� �����
|
|
0
|
31 sub STATE_CLOSED () { 0 }
|
|
49
|
32 # �������� ������, �.�. ������ �����, �� � ��� ��� ������ �� �����
|
|
0
|
33 sub STATE_OPENED () { 1 }
|
|
49
|
34 # �������� ������ � � ���� ����� ���� ��������� ������ ����������
|
|
0
|
35 sub STATE_COMPLEX () { 2 }
|
|
49
|
36 # �������� ������ � � ���� ��� ������ �� ����� ���� ���������, ��� ����� ������
|
|
0
|
37 sub STATE_DATA () { 3 }
|
|
|
38
|
|
|
39 sub CTOR {
|
|
|
40 my ($this,%args) = @_;
|
|
|
41
|
|
|
42 $this->{$ObjectWriter} = $args{'ObjectWriter'};
|
|
|
43 #$this->{$Context} = {};
|
|
|
44 $this->{$NextID} = 1;
|
|
|
45 $this->{$Serializer} = ($args{'Serializer'} ? $args{'Serializer'} : \&DefaultSerializer );
|
|
|
46 $this->{$State} = STATE_CLOSED;
|
|
|
47
|
|
|
48 return 1;
|
|
|
49 }
|
|
|
50
|
|
|
51 sub AddVar {
|
|
|
52 my ($this,$sName,$Var) = @_;
|
|
|
53
|
|
|
54 die new Exception ('Invalid operation') if $this->{$State} == STATE_DATA;
|
|
|
55
|
|
|
56 if (not ref $Var) {
|
|
49
|
57 # ������� ����������� ��, ��� �����, �� ��� ���� ����, ����� �������, ������� ����
|
|
|
58 # �� �� ������, �� �������� ��������������, �� �� �� �����
|
|
0
|
59 my $prevState = $this->{$State};
|
|
|
60
|
|
|
61 $this->{$ObjectWriter}->BeginObject(name => $sName);#, type => 'SCALAR');
|
|
|
62 $this->{$State} = STATE_OPENED;
|
|
|
63
|
|
|
64 $this->{$Serializer}->($this,\$Var);
|
|
|
65
|
|
|
66 $this->{$ObjectWriter}->EndObject();
|
|
|
67
|
|
|
68 if ($prevState == STATE_OPENED) {
|
|
|
69 $this->{$State} = STATE_COMPLEX;
|
|
|
70 } else {
|
|
|
71 $this->{$State} = $prevState;
|
|
|
72 }
|
|
|
73 return 0;
|
|
|
74 }
|
|
|
75
|
|
|
76 my $PrevState = $this->{$State};
|
|
|
77
|
|
|
78 my $ObjID = $this->{$Context}->{refaddr $Var};
|
|
|
79 if ($ObjID) {
|
|
|
80 $this->{$ObjectWriter}->BeginObject(name => $sName, refid => $ObjID);
|
|
|
81 $this->{$ObjectWriter}->EndObject();
|
|
|
82 return $ObjID;
|
|
|
83 }
|
|
|
84
|
|
|
85 $ObjID = $this->{$NextID};
|
|
|
86 $this->{$NextID} = $ObjID + 1;
|
|
|
87
|
|
|
88 $this->{$Context}->{refaddr $Var} = $ObjID;
|
|
|
89
|
|
|
90 $this->{$ObjectWriter}->BeginObject(name => $sName, type => ref($Var), id => $ObjID);
|
|
|
91
|
|
|
92 $this->{$State} = STATE_OPENED;
|
|
|
93 $this->{$Serializer}->($this,$Var);
|
|
|
94
|
|
|
95 $this->{$ObjectWriter}->EndObject();
|
|
|
96
|
|
|
97 if ($PrevState == STATE_OPENED) {
|
|
|
98 $this->{$State} = STATE_COMPLEX;
|
|
|
99 } else {
|
|
|
100 $this->{$State} = $PrevState;
|
|
|
101 }
|
|
|
102
|
|
|
103 return $ObjID;
|
|
|
104 }
|
|
|
105
|
|
|
106 sub SetData {
|
|
|
107 my ($this,$Data,$Type) = @_;
|
|
|
108
|
|
|
109 die new Exception ('The object should be a scalar value') if ref $Data;
|
|
|
110 die new Exception ('Invalid operation') if $this->{$State} != STATE_OPENED;
|
|
|
111
|
|
|
112 $this->{$ObjectWriter}->SetData($Data,$Type);
|
|
|
113
|
|
|
114 $this->{$State} = STATE_DATA;
|
|
|
115
|
|
|
116 return 1;
|
|
|
117 }
|
|
|
118
|
|
|
119 sub DefaultSerializer {
|
|
|
120 my ($Context, $refObj) = @_;
|
|
|
121
|
|
|
122 if (ref($refObj) eq 'SCALAR') {
|
|
|
123 $Context->SetData($$refObj, 'SCALAR');
|
|
|
124 } elsif (ref($refObj) eq 'ARRAY') {
|
|
|
125 $Context->AddVar('item',$_) foreach @$refObj;
|
|
|
126 } elsif (ref($refObj) eq 'HASH') {
|
|
|
127 while (my ($key,$value) = each %$refObj) {
|
|
|
128 $Context->AddVar($key,$value);
|
|
|
129 }
|
|
|
130 } elsif (ref($refObj) eq 'REF') {
|
|
|
131 $Context->AddVar('ref',$$refObj);
|
|
|
132 } else {
|
|
|
133 if (ref $refObj and $refObj->UNIVARSAL::can('save')) {
|
|
|
134 $refObj->save($Context);
|
|
|
135 } else {
|
|
|
136 die new Exception('Cant serialize the object of the type: '.ref($refObj));
|
|
|
137 }
|
|
|
138 }
|
|
|
139
|
|
|
140 return 1;
|
|
|
141 }
|
|
|
142
|
|
|
143 package IMPL::Deserialization::Context;
|
|
|
144 use base qw(IMPL::Object);
|
|
|
145
|
|
|
146 use IMPL::Class::Property;
|
|
|
147 use IMPL::Class::Property::Direct;
|
|
|
148 use IMPL::Exception;
|
|
|
149
|
|
|
150 BEGIN {
|
|
49
|
151 # ��� ����������������� �������, ���, ���� - �������������, �������� - ������.
|
|
0
|
152 private _direct property Context => prop_all;
|
|
|
153
|
|
49
|
154 # ������� ������. ���������� ��� ��������������
|
|
0
|
155 # {
|
|
|
156 # Type => 'typename',
|
|
|
157 # Name => 'object_name',
|
|
|
158 # Data => $Data,
|
|
|
159 # Id => 'object_id'
|
|
|
160 # }
|
|
|
161 private _direct property CurrentObject => prop_all;
|
|
|
162
|
|
49
|
163 # ���� ��������. ���� ����������� �������� �������� �� ���� ���������� ����� ��������.
|
|
0
|
164 private _direct property ObjectsPath => prop_all;
|
|
|
165
|
|
49
|
166 # ���� ������� ������ ����� ��������
|
|
0
|
167 public _direct property Root => prop_get;
|
|
|
168
|
|
49
|
169 # ������� ������ � ���������� �� ���� ������
|
|
0
|
170 # ObjectFactory($Type,$DeserializationData,$refSurogate)
|
|
49
|
171 # $Type - ��� ���� ������
|
|
|
172 # $DeserializationData - ���� ������ �� ������ � ������� ��� �������������� �����,
|
|
|
173 # ���� ������ ���������� ������.
|
|
|
174 # $refSurogate - ������ �� �������������� ���������, �� ������������������ ������.
|
|
|
175 # ����� ��������� �������� undef
|
|
0
|
176 private _direct property ObjectFactory => prop_all;
|
|
|
177
|
|
49
|
178 # ������� �������������������� �������.
|
|
0
|
179 # SurogateHelper($Type)
|
|
49
|
180 # $Type ��� �����, ��� ������� ����� �������.
|
|
0
|
181 private _direct property SurogateHelper => prop_all;
|
|
|
182 }
|
|
|
183
|
|
|
184 sub CTOR {
|
|
|
185 my ($this,%args) = @_;
|
|
|
186 $this->{$CurrentObject} = undef;
|
|
|
187 $this->{$Root} = undef;
|
|
|
188 }
|
|
|
189
|
|
|
190 sub OnObjectBegin {
|
|
|
191 my ($this,$name,$rhProps) = @_;
|
|
|
192
|
|
|
193 die new Exception("Invalid data from an ObjectReader","An object reader should pass a referense to a hash which contains attributes of an object") if (ref $rhProps ne 'HASH');
|
|
|
194 die new Exception("Trying to create second root object") if not $this->{$CurrentObject} and $this->{$Root};
|
|
|
195
|
|
|
196 if ($rhProps->{'refid'}) {
|
|
|
197 my $refObj = $this->{$Context}->{$rhProps->{'refid'}};
|
|
|
198 die new Exception("A reference to a not existing object found") if not $refObj;
|
|
|
199 my $rhCurrentObj = $this->{$CurrentObject};
|
|
|
200
|
|
|
201 die new Exception("Found a reference to an object as a root of an object's graph") if not $rhCurrentObj;
|
|
|
202
|
|
|
203 if ($rhCurrentObj->{'Data'}) {
|
|
|
204 die new Exception("Invalid serializaed data","Plain deserialization data for an object already exist") if not ref $rhCurrentObj->{'Data'};
|
|
|
205 push @{$rhCurrentObj->{'Data'}}, $name,$refObj;
|
|
|
206 } else {
|
|
|
207 $rhCurrentObj->{'Data'} = [$name,$refObj];
|
|
|
208 }
|
|
|
209
|
|
49
|
210 # ��� �����, ��� ����� ������ OnObjectEnd ��� �������, ������� ��� ������� �������. �.�. �� �� ������� ����
|
|
0
|
211 push @{$this->{$ObjectsPath}},$rhCurrentObj;
|
|
|
212 $this->{$CurrentObject} = undef;
|
|
|
213
|
|
|
214 } else {
|
|
|
215 push @{$this->{$ObjectsPath}},$this->{$CurrentObject} if $this->{$CurrentObject};
|
|
|
216
|
|
|
217 $this->{$CurrentObject} = {
|
|
|
218 Name => $name,
|
|
|
219 Type => $rhProps->{'type'} || 'SCALAR',
|
|
|
220 Id => $rhProps->{'id'},
|
|
|
221 refId => $rhProps->{'refid'}
|
|
|
222 };
|
|
|
223 $this->{$Context}->{$rhProps->{'id'}} = $this->{$SurogateHelper} ? $this->{$SurogateHelper}->($rhProps->{'type'}) : DefaultSurogateHelper($rhProps->{'type'}) if defined $rhProps->{'id'};
|
|
|
224 }
|
|
|
225
|
|
|
226 return 1;
|
|
|
227 }
|
|
|
228
|
|
|
229 sub OnObjectData {
|
|
|
230 my ($this,$data) = @_;
|
|
|
231
|
|
|
232 my $rhObject = $this->{$CurrentObject};
|
|
|
233
|
|
|
234 die new Exception("Trying to set data for an object which not exists") if not $rhObject;
|
|
|
235
|
|
|
236 die new Exception("Deserialization data already exists for a current object", "ObjectName= $rhObject->{'Name'}") if $rhObject->{'Data'};
|
|
|
237
|
|
|
238 $rhObject->{'Data'} = $data;
|
|
|
239
|
|
|
240 return 1;
|
|
|
241 }
|
|
|
242 {
|
|
|
243 my $AutoId = 0;
|
|
|
244 sub OnObjectEnd {
|
|
|
245 my ($this,$name) = @_;
|
|
|
246
|
|
|
247 my $rhObject = $this->{$CurrentObject};
|
|
|
248 my $rhPrevObject = pop @{$this->{$ObjectsPath}};
|
|
|
249
|
|
49
|
250 # ���� ������� ������ �� ���������, � ���������� - ���������, ������ ������� - ��� ������
|
|
|
251 # ������ ��������������� ���������� � ������� � ������ ����� �� ������
|
|
0
|
252 if ((not defined($rhObject)) && $rhPrevObject) {
|
|
|
253 $this->{$CurrentObject} = $rhPrevObject;
|
|
|
254 return 1;
|
|
|
255 }
|
|
|
256
|
|
|
257 my $refObj = $this->{$ObjectFactory} ?$this->{$ObjectFactory}->($rhObject->{'Type'},$rhObject->{'Data'},$rhObject->{'Id'} ? $this->{$Context}->{$rhObject->{'Id'}} : undef) : DefaultFactory($rhObject->{'Type'},$rhObject->{'Data'},$rhObject->{'Id'} ? $this->{$Context}->{$rhObject->{'Id'}} : undef);
|
|
|
258
|
|
|
259 die new Exception("Trying to close a non existing oject") if not $rhObject;
|
|
|
260
|
|
|
261 my $Data;
|
|
|
262
|
|
|
263 if ($rhObject->{'Id'}) {
|
|
|
264 $this->{$Context}->{$rhObject->{'Id'}} = $refObj;
|
|
|
265 $Data = $refObj;
|
|
|
266 } else {
|
|
|
267 if (ref $refObj ne 'SCALAR') {
|
|
|
268 $rhObject->{Id} = "auto$AutoId";
|
|
|
269 $AutoId ++;
|
|
|
270 $this->{$Context}->{$rhObject->{'Id'}} = $refObj;
|
|
|
271 $Data = $refObj;
|
|
|
272 } else {
|
|
|
273 $Data = ${$refObj};
|
|
|
274 }
|
|
|
275 }
|
|
|
276
|
|
|
277 if (not $rhPrevObject) {
|
|
|
278 $this->{$Root} = $Data;
|
|
|
279 } else {
|
|
|
280 if ($rhPrevObject->{'Data'}) {
|
|
|
281 die new Exception("Trying append a reference to an object to the plain data") if not ref $rhPrevObject->{'Data'};
|
|
|
282 push @{$rhPrevObject->{'Data'}},$rhObject->{'Name'},$Data;
|
|
|
283 } else {
|
|
|
284 $rhPrevObject->{'Data'} = [$rhObject->{'Name'},$Data];
|
|
|
285 }
|
|
|
286 }
|
|
|
287
|
|
|
288 $this->{$CurrentObject} = $rhPrevObject;
|
|
|
289
|
|
|
290 return 1;
|
|
|
291 }
|
|
|
292 }
|
|
|
293
|
|
|
294 sub _is_class {
|
|
|
295 no strict 'refs';
|
|
|
296 scalar keys %{"$_[0]::"} ? 1 : 0;
|
|
|
297 }
|
|
|
298
|
|
|
299 sub DefaultSurogateHelper {
|
|
|
300 my ($Type) = @_;
|
|
|
301
|
|
|
302 if ($Type eq 'SCALAR' or $Type eq 'REF') {
|
|
|
303 my $var;
|
|
|
304 return \$var;
|
|
|
305 } elsif ($Type eq 'ARRAY') {
|
|
|
306 return [];
|
|
|
307 } elsif ($Type eq 'HASH') {
|
|
|
308 return {};
|
|
|
309 } else {
|
|
|
310 eval "require $Type" unless _is_class($Type);
|
|
|
311 if ($Type->UNIVERSAL::can('surrogate')) {
|
|
|
312 return $Type->surrogate();
|
|
|
313 } else {
|
|
|
314 return bless {}, $Type;
|
|
|
315 }
|
|
|
316 }
|
|
|
317 }
|
|
|
318
|
|
|
319 # deserialization context:
|
|
|
320 # [
|
|
|
321 # 'var_name',value,
|
|
|
322 # ....
|
|
|
323 # ]
|
|
|
324
|
|
|
325 sub DefaultFactory {
|
|
|
326 my ($Type,$Data,$refSurogate) = @_;
|
|
|
327
|
|
|
328 if ($Type eq 'SCALAR') {
|
|
|
329 die new Exception("SCALAR needs a plain data for a deserialization") if ref $Data;
|
|
|
330 if ($refSurogate) {
|
|
|
331 $$refSurogate = $Data;
|
|
|
332 return $refSurogate;
|
|
|
333 } else {
|
|
|
334 return \$Data;
|
|
|
335 }
|
|
|
336 } elsif ($Type eq 'ARRAY') {
|
|
|
337 die new Exception("Invalid a deserialization context when deserializing ARRAY") if not ref $Data and defined $Data;
|
|
|
338 if (not ref $refSurogate) {
|
|
|
339 my @Array;
|
|
|
340 $refSurogate = \@Array;
|
|
|
341 }
|
|
|
342 for (my $i = 0; $i < scalar(@{$Data})/2; $i++) {
|
|
|
343 push @$refSurogate,$Data->[$i*2+1];
|
|
|
344 }
|
|
|
345 return $refSurogate;
|
|
|
346 } elsif ($Type eq 'HASH') {
|
|
|
347 die new Exception("Invalid a deserialization context when deserializing HASH") if not ref $Data and defined $Data;
|
|
|
348 if (not ref $refSurogate) {
|
|
|
349 $refSurogate = {};
|
|
|
350 }
|
|
|
351 for (my $i = 0; $i< @$Data; $i+= 2) {
|
|
|
352 $refSurogate->{$Data->[$i]} = $Data->[$i+1];
|
|
|
353 }
|
|
|
354 return $refSurogate;
|
|
|
355 } elsif ($Type eq 'REF') {
|
|
|
356 die new Exception("Invalid a deserialization context when deserializing REF") if not ref $Data and defined $Data;
|
|
|
357 if (not ref $refSurogate) {
|
|
|
358 my $ref = $Data->[1];
|
|
|
359 return \$ref;
|
|
|
360 } else {
|
|
|
361 $$refSurogate = $Data->[1];
|
|
|
362 return $refSurogate;
|
|
|
363 }
|
|
|
364 } else {
|
|
|
365 eval "require $Type" unless _is_class($Type);
|
|
|
366 if ( $Type->UNIVERSAL::can('restore') ) {
|
|
|
367 return $Type->restore($Data,$refSurogate);
|
|
|
368 } else {
|
|
|
369 die new Exception("Don't know how to deserialize $Type");
|
|
|
370 }
|
|
|
371 }
|
|
|
372 }
|
|
|
373
|
|
|
374 package IMPL::Serializer;
|
|
|
375 use base qw(IMPL::Object);
|
|
|
376
|
|
|
377 use IMPL::Class::Property;
|
|
|
378 use IMPL::Class::Property::Direct;
|
|
|
379 use IMPL::Exception;
|
|
|
380
|
|
|
381 BEGIN {
|
|
|
382 private _direct property Formatter => prop_all;
|
|
|
383 }
|
|
|
384
|
|
|
385 sub CTOR {
|
|
|
386 my ($this,%args) = @_;
|
|
|
387 $this->Formatter($args{'Formatter'}) or die new Exception("Omitted mandatory parameter 'Formatter'");
|
|
|
388 }
|
|
|
389
|
|
|
390 sub Serialize {
|
|
|
391 my $this = shift;
|
|
|
392 my ($hStream,$Object) = @_;
|
|
|
393 my $ObjWriter = $this->Formatter()->CreateWriter($hStream);
|
|
|
394 my $Context = new IMPL::Serialization::Context(ObjectWriter => $ObjWriter);
|
|
|
395 $Context->AddVar('root',$Object);
|
|
|
396 return 1;
|
|
|
397 }
|
|
|
398
|
|
|
399 sub Deserialize {
|
|
|
400 my $this = shift;
|
|
|
401 my ($hStream) = @_;
|
|
|
402 my $Context = new IMPL::Deserialization::Context();
|
|
|
403 my $ObjReader = $this->Formatter()->CreateReader($hStream,$Context);
|
|
|
404 $ObjReader->Parse();
|
|
|
405 return $Context->Root();
|
|
|
406 }
|
|
|
407
|
|
49
|
408 1;
|
