Mercurial > pub > Impl
annotate Lib/IMPL/Serialization.pm @ 125:a4b0a819bbda
Small fixes in IMPL::DOM::Schema
| author | wizard |
|---|---|
| date | Thu, 10 Jun 2010 17:43:51 +0400 |
| parents | 5edc2ac5231c |
| children | fb896377389f |
| rev | line source |
|---|---|
| 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 ��� �����, ��� ������� ����� �������. |
| 115 | 181 private _direct property SurrogateHelper => prop_all; |
| 0 | 182 } |
| 183 | |
| 184 sub CTOR { | |
| 185 my ($this,%args) = @_; | |
| 186 $this->{$CurrentObject} = undef; | |
| 187 $this->{$Root} = undef; | |
| 115 | 188 $this->{$ObjectFactory} = $args{ObjectFactory} if $args{ObjectFactory}; |
| 189 $this->{$SurrogateHelper} = $args{SurrogateHelper} if $args{SurrogateHelper}; | |
| 0 | 190 } |
| 191 | |
| 192 sub OnObjectBegin { | |
| 193 my ($this,$name,$rhProps) = @_; | |
| 194 | |
| 195 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'); | |
| 196 die new Exception("Trying to create second root object") if not $this->{$CurrentObject} and $this->{$Root}; | |
| 197 | |
| 198 if ($rhProps->{'refid'}) { | |
| 199 my $refObj = $this->{$Context}->{$rhProps->{'refid'}}; | |
| 200 die new Exception("A reference to a not existing object found") if not $refObj; | |
| 201 my $rhCurrentObj = $this->{$CurrentObject}; | |
| 202 | |
| 203 die new Exception("Found a reference to an object as a root of an object's graph") if not $rhCurrentObj; | |
| 204 | |
| 205 if ($rhCurrentObj->{'Data'}) { | |
| 206 die new Exception("Invalid serializaed data","Plain deserialization data for an object already exist") if not ref $rhCurrentObj->{'Data'}; | |
| 207 push @{$rhCurrentObj->{'Data'}}, $name,$refObj; | |
| 208 } else { | |
| 209 $rhCurrentObj->{'Data'} = [$name,$refObj]; | |
| 210 } | |
| 211 | |
| 49 | 212 # ��� �����, ��� ����� ������ OnObjectEnd ��� �������, ������� ��� ������� �������. �.�. �� �� ������� ���� |
| 0 | 213 push @{$this->{$ObjectsPath}},$rhCurrentObj; |
| 214 $this->{$CurrentObject} = undef; | |
| 215 | |
| 216 } else { | |
| 217 push @{$this->{$ObjectsPath}},$this->{$CurrentObject} if $this->{$CurrentObject}; | |
| 218 | |
| 219 $this->{$CurrentObject} = { | |
| 220 Name => $name, | |
| 221 Type => $rhProps->{'type'} || 'SCALAR', | |
| 222 Id => $rhProps->{'id'}, | |
| 223 refId => $rhProps->{'refid'} | |
| 224 }; | |
|
60
b0c068da93ac
Lazy activation for the configuration objects (final concept)
wizard
parents:
49
diff
changeset
|
225 |
|
b0c068da93ac
Lazy activation for the configuration objects (final concept)
wizard
parents:
49
diff
changeset
|
226 if (defined $rhProps->{'id'}) { |
|
b0c068da93ac
Lazy activation for the configuration objects (final concept)
wizard
parents:
49
diff
changeset
|
227 die new IMPL::Exception("Trying to create a simple object instead of a reference, type is missing.",$name,$rhProps->{id}) unless $rhProps->{'type'} ; |
| 115 | 228 $this->{$Context}->{$rhProps->{'id'}} = $this->{$SurrogateHelper} ? $this->{$SurrogateHelper}->($rhProps->{'type'}) : DefaultSurrogateHelper($rhProps->{'type'}); |
|
60
b0c068da93ac
Lazy activation for the configuration objects (final concept)
wizard
parents:
49
diff
changeset
|
229 } |
| 0 | 230 } |
| 231 | |
| 232 return 1; | |
| 233 } | |
| 234 | |
| 235 sub OnObjectData { | |
| 236 my ($this,$data) = @_; | |
| 237 | |
| 238 my $rhObject = $this->{$CurrentObject}; | |
| 239 | |
| 240 die new Exception("Trying to set data for an object which not exists") if not $rhObject; | |
| 241 | |
| 242 die new Exception("Deserialization data already exists for a current object", "ObjectName= $rhObject->{'Name'}") if $rhObject->{'Data'}; | |
| 243 | |
| 244 $rhObject->{'Data'} = $data; | |
| 245 | |
| 246 return 1; | |
| 247 } | |
| 248 { | |
| 249 my $AutoId = 0; | |
| 250 sub OnObjectEnd { | |
| 251 my ($this,$name) = @_; | |
| 252 | |
| 253 my $rhObject = $this->{$CurrentObject}; | |
| 254 my $rhPrevObject = pop @{$this->{$ObjectsPath}}; | |
| 255 | |
| 49 | 256 # ���� ������� ������ �� ���������, � ���������� - ���������, ������ ������� - ��� ������ |
| 257 # ������ ��������������� ���������� � ������� � ������ ����� �� ������ | |
| 0 | 258 if ((not defined($rhObject)) && $rhPrevObject) { |
| 259 $this->{$CurrentObject} = $rhPrevObject; | |
| 260 return 1; | |
| 261 } | |
| 262 | |
| 263 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); | |
| 264 | |
| 265 die new Exception("Trying to close a non existing oject") if not $rhObject; | |
| 266 | |
| 267 my $Data; | |
| 268 | |
| 269 if ($rhObject->{'Id'}) { | |
| 270 $this->{$Context}->{$rhObject->{'Id'}} = $refObj; | |
| 271 $Data = $refObj; | |
| 272 } else { | |
| 273 if (ref $refObj ne 'SCALAR') { | |
| 274 $rhObject->{Id} = "auto$AutoId"; | |
| 275 $AutoId ++; | |
| 276 $this->{$Context}->{$rhObject->{'Id'}} = $refObj; | |
| 277 $Data = $refObj; | |
| 278 } else { | |
| 279 $Data = ${$refObj}; | |
| 280 } | |
| 281 } | |
| 282 | |
| 283 if (not $rhPrevObject) { | |
| 284 $this->{$Root} = $Data; | |
| 285 } else { | |
| 286 if ($rhPrevObject->{'Data'}) { | |
| 287 die new Exception("Trying append a reference to an object to the plain data") if not ref $rhPrevObject->{'Data'}; | |
| 288 push @{$rhPrevObject->{'Data'}},$rhObject->{'Name'},$Data; | |
| 289 } else { | |
| 290 $rhPrevObject->{'Data'} = [$rhObject->{'Name'},$Data]; | |
| 291 } | |
| 292 } | |
| 293 | |
| 294 $this->{$CurrentObject} = $rhPrevObject; | |
| 295 | |
| 296 return 1; | |
| 297 } | |
| 298 } | |
| 299 | |
| 300 sub _is_class { | |
| 301 no strict 'refs'; | |
| 302 scalar keys %{"$_[0]::"} ? 1 : 0; | |
| 303 } | |
| 304 | |
| 115 | 305 sub DefaultSurrogateHelper { |
| 0 | 306 my ($Type) = @_; |
| 307 | |
| 308 if ($Type eq 'SCALAR' or $Type eq 'REF') { | |
| 309 my $var; | |
| 310 return \$var; | |
| 311 } elsif ($Type eq 'ARRAY') { | |
| 312 return []; | |
| 313 } elsif ($Type eq 'HASH') { | |
| 314 return {}; | |
|
60
b0c068da93ac
Lazy activation for the configuration objects (final concept)
wizard
parents:
49
diff
changeset
|
315 } elsif ($Type) { |
| 0 | 316 eval "require $Type" unless _is_class($Type); |
|
60
b0c068da93ac
Lazy activation for the configuration objects (final concept)
wizard
parents:
49
diff
changeset
|
317 if (UNIVERSAL::can($Type,'surrogate')) { |
| 0 | 318 return $Type->surrogate(); |
| 319 } else { | |
| 320 return bless {}, $Type; | |
| 321 } | |
| 322 } | |
| 323 } | |
| 324 | |
| 325 # deserialization context: | |
| 326 # [ | |
| 327 # 'var_name',value, | |
| 328 # .... | |
| 329 # ] | |
| 330 | |
| 331 sub DefaultFactory { | |
| 332 my ($Type,$Data,$refSurogate) = @_; | |
| 333 | |
| 334 if ($Type eq 'SCALAR') { | |
| 335 die new Exception("SCALAR needs a plain data for a deserialization") if ref $Data; | |
| 336 if ($refSurogate) { | |
| 337 $$refSurogate = $Data; | |
| 338 return $refSurogate; | |
| 339 } else { | |
| 340 return \$Data; | |
| 341 } | |
| 342 } elsif ($Type eq 'ARRAY') { | |
| 343 die new Exception("Invalid a deserialization context when deserializing ARRAY") if not ref $Data and defined $Data; | |
| 344 if (not ref $refSurogate) { | |
| 345 my @Array; | |
| 346 $refSurogate = \@Array; | |
| 347 } | |
| 348 for (my $i = 0; $i < scalar(@{$Data})/2; $i++) { | |
| 349 push @$refSurogate,$Data->[$i*2+1]; | |
| 350 } | |
| 351 return $refSurogate; | |
| 352 } elsif ($Type eq 'HASH') { | |
| 353 die new Exception("Invalid a deserialization context when deserializing HASH") if not ref $Data and defined $Data; | |
| 354 if (not ref $refSurogate) { | |
| 355 $refSurogate = {}; | |
| 356 } | |
| 357 for (my $i = 0; $i< @$Data; $i+= 2) { | |
| 358 $refSurogate->{$Data->[$i]} = $Data->[$i+1]; | |
| 359 } | |
| 360 return $refSurogate; | |
| 361 } elsif ($Type eq 'REF') { | |
| 362 die new Exception("Invalid a deserialization context when deserializing REF") if not ref $Data and defined $Data; | |
| 363 if (not ref $refSurogate) { | |
| 364 my $ref = $Data->[1]; | |
| 365 return \$ref; | |
| 366 } else { | |
| 367 $$refSurogate = $Data->[1]; | |
| 368 return $refSurogate; | |
| 369 } | |
| 370 } else { | |
| 371 eval "require $Type" unless _is_class($Type); | |
| 372 if ( $Type->UNIVERSAL::can('restore') ) { | |
| 373 return $Type->restore($Data,$refSurogate); | |
| 374 } else { | |
| 375 die new Exception("Don't know how to deserialize $Type"); | |
| 376 } | |
| 377 } | |
| 378 } | |
| 379 | |
| 380 package IMPL::Serializer; | |
| 381 use base qw(IMPL::Object); | |
| 382 | |
| 383 use IMPL::Class::Property; | |
| 384 use IMPL::Class::Property::Direct; | |
| 385 use IMPL::Exception; | |
| 386 | |
| 387 BEGIN { | |
| 388 private _direct property Formatter => prop_all; | |
| 389 } | |
| 390 | |
| 391 sub CTOR { | |
| 392 my ($this,%args) = @_; | |
| 393 $this->Formatter($args{'Formatter'}) or die new Exception("Omitted mandatory parameter 'Formatter'"); | |
| 394 } | |
| 395 | |
| 396 sub Serialize { | |
| 397 my $this = shift; | |
| 398 my ($hStream,$Object) = @_; | |
| 399 my $ObjWriter = $this->Formatter()->CreateWriter($hStream); | |
| 400 my $Context = new IMPL::Serialization::Context(ObjectWriter => $ObjWriter); | |
| 401 $Context->AddVar('root',$Object); | |
| 402 return 1; | |
| 403 } | |
| 404 | |
| 405 sub Deserialize { | |
| 406 my $this = shift; | |
| 407 my ($hStream) = @_; | |
| 408 my $Context = new IMPL::Deserialization::Context(); | |
| 409 my $ObjReader = $this->Formatter()->CreateReader($hStream,$Context); | |
| 410 $ObjReader->Parse(); | |
| 411 return $Context->Root(); | |
| 412 } | |
| 413 | |
| 49 | 414 1; |