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