Mercurial > pub > Impl
annotate Lib/IMPL/Serialization.pm @ 199:e743a8481327
Added REST support for forms (with only get and post methods)
| author | sergey |
|---|---|
| date | Mon, 23 Apr 2012 01:36:52 +0400 |
| parents | 2ffe6f661605 |
| children | 5146e17a7b76 |
| 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 | |
| 185 die new Exception("Found a reference to an object as a root of an object's graph") if not $rhCurrentObj; | |
| 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 | |
| 198 | 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 |
|
e743a8481327
Added REST support for forms (with only get and post methods)
sergey
parents:
198
diff
changeset
|
287 die new IMPL::Exception("Invalid class name",$_[0]) unless $_[0] =~ m/^\w+(\:\:\w+)*$/; |
|
e743a8481327
Added REST support for forms (with only get and post methods)
sergey
parents:
198
diff
changeset
|
288 |
|
e743a8481327
Added REST support for forms (with only get and post methods)
sergey
parents:
198
diff
changeset
|
289 eval "require $_[0]"; |
|
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') { | |
| 332 die new Exception("Invalid a deserialization context when deserializing ARRAY") if not ref $Data and defined $Data; | |
| 333 if (not ref $refSurogate) { | |
| 334 my @Array; | |
| 335 $refSurogate = \@Array; | |
| 336 } | |
| 337 for (my $i = 0; $i < scalar(@{$Data})/2; $i++) { | |
| 338 push @$refSurogate,$Data->[$i*2+1]; | |
| 339 } | |
| 340 return $refSurogate; | |
| 341 } elsif ($Type eq 'HASH') { | |
| 342 die new Exception("Invalid a deserialization context when deserializing HASH") if not ref $Data and defined $Data; | |
| 343 if (not ref $refSurogate) { | |
| 344 $refSurogate = {}; | |
| 345 } | |
| 346 for (my $i = 0; $i< @$Data; $i+= 2) { | |
| 347 $refSurogate->{$Data->[$i]} = $Data->[$i+1]; | |
| 348 } | |
| 349 return $refSurogate; | |
| 350 } elsif ($Type eq 'REF') { | |
| 351 die new Exception("Invalid a deserialization context when deserializing REF") if not ref $Data and defined $Data; | |
| 352 if (not ref $refSurogate) { | |
| 353 my $ref = $Data->[1]; | |
| 354 return \$ref; | |
| 355 } else { | |
| 356 $$refSurogate = $Data->[1]; | |
| 357 return $refSurogate; | |
| 358 } | |
| 359 } else { | |
| 198 | 360 _load_class($Type); |
| 0 | 361 if ( $Type->UNIVERSAL::can('restore') ) { |
| 362 return $Type->restore($Data,$refSurogate); | |
| 363 } else { | |
| 364 die new Exception("Don't know how to deserialize $Type"); | |
| 365 } | |
| 366 } | |
| 367 } | |
| 368 | |
| 369 package IMPL::Serializer; | |
| 166 | 370 use parent qw(IMPL::Object); |
| 0 | 371 |
| 372 use IMPL::Class::Property; | |
| 373 use IMPL::Class::Property::Direct; | |
| 374 use IMPL::Exception; | |
| 375 | |
| 376 BEGIN { | |
| 377 private _direct property Formatter => prop_all; | |
| 378 } | |
| 379 | |
| 380 sub CTOR { | |
| 381 my ($this,%args) = @_; | |
| 382 $this->Formatter($args{'Formatter'}) or die new Exception("Omitted mandatory parameter 'Formatter'"); | |
| 383 } | |
| 384 | |
| 385 sub Serialize { | |
| 386 my $this = shift; | |
| 387 my ($hStream,$Object) = @_; | |
| 388 my $ObjWriter = $this->Formatter()->CreateWriter($hStream); | |
| 389 my $Context = new IMPL::Serialization::Context(ObjectWriter => $ObjWriter); | |
| 390 $Context->AddVar('root',$Object); | |
| 391 return 1; | |
| 392 } | |
| 393 | |
| 394 sub Deserialize { | |
| 395 my $this = shift; | |
| 396 my ($hStream) = @_; | |
| 397 my $Context = new IMPL::Deserialization::Context(); | |
| 398 my $ObjReader = $this->Formatter()->CreateReader($hStream,$Context); | |
| 399 $ObjReader->Parse(); | |
| 400 return $Context->Root(); | |
| 401 } | |
| 402 | |
| 49 | 403 1; |