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