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