Mercurial > pub > Impl
annotate Lib/IMPL/Serialization.pm @ 245:7c517134c42f
Added Unsupported media type Web exception
corrected resourceLocation setting in the resource
Implemented localizable resources for text messages
fixed TT view scopings, INIT block in controls now sets globals correctly.
author | sergey |
---|---|
date | Mon, 29 Oct 2012 03:15:22 +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; |