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