pub/Impl: Lib/IMPL/Serialization.pm comparison

comparison Lib/IMPL/Serialization.pm @ 0:03e58a454b20

РЎРѕР·РґР°РЅ СЂРµРїРѕР·РёС‚Р°СЂРёР№

author	Sergey
date	Tue, 14 Jul 2009 12:54:37 +0400
parents
children	16ada169ca75

comparison

equal deleted inserted replaced

--1:000000000000
+:03e58a454b20
+# 20060222
+# Модуль для сериализации структур данных
+# (ц) Sourcer, cin.sourcer@gmail.com
+# revision 3 (20090517)
+package IMPL::Serialization;
+use strict;
+package IMPL::Serialization::Context;
+use base qw(IMPL::Object);
+use IMPL::Class::Property;
+use IMPL::Class::Property::Direct;
+use IMPL::Exception;
+use Scalar::Util qw(refaddr);
+BEGIN {
+private _direct property ObjectWriter => prop_all; # объект, записывающий данные в поток
+private _direct property Context => prop_all; # контекст (объекты которые уже сериализованы, их идентификаторы)
+private _direct property NextID => prop_all;# следующий идентификатор для объекта
+# процедура, которая знает, как сериализовывать определенные типы. Первым параметром
+# получаем ссылку на IMPL::Serialization::Context, вторым параметром ссылку на объект
+public _direct property Serializer => prop_all;
+private _direct property State => prop_all; # состояние контекста сериализации
+}
+# контекст закрыт, т.е. никакой объект не начат
+sub STATE_CLOSED () { 0 }
+# контекст открыт, т.е. объект начат, но в нем еще ничего не лежит
+sub STATE_OPENED () { 1 }
+# контекст открыт и в него могут быть добавлены только подобъекты
+sub STATE_COMPLEX () { 2 }
+# контекст открыт и в него уже ничего не может быть добавлено, там лежат данные
+sub STATE_DATA () { 3 }
+sub CTOR {
+my ($this,%args) = @_;
+$this->{$ObjectWriter} = $args{'ObjectWriter'};
+#$this->{$Context} = {};
+$this->{$NextID} = 1;
+$this->{$Serializer} = ($args{'Serializer'} ? $args{'Serializer'} : \&DefaultSerializer );
+$this->{$State} = STATE_CLOSED;
+return 1;
+}
+sub AddVar {
+my ($this,$sName,$Var) = @_;
+die new Exception ('Invalid operation') if $this->{$State} == STATE_DATA;
+if (not ref $Var) {
+# немного дублируется то, что снизу, но это ради того, чтобы объекты, которые идут
+# не по ссылке, не получали идентификатора, им он не нужен
+my $prevState = $this->{$State};
+$this->{$ObjectWriter}->BeginObject(name => $sName);#, type => 'SCALAR');
+$this->{$State} = STATE_OPENED;
+$this->{$Serializer}->($this,\$Var);
+$this->{$ObjectWriter}->EndObject();
+if ($prevState == STATE_OPENED) {
+$this->{$State} = STATE_COMPLEX;
+} else {
+$this->{$State} = $prevState;
+}
+return 0;
+}
+my $PrevState = $this->{$State};
+my $ObjID = $this->{$Context}->{refaddr $Var};
+if ($ObjID) {
+$this->{$ObjectWriter}->BeginObject(name => $sName, refid => $ObjID);
+$this->{$ObjectWriter}->EndObject();
+return $ObjID;
+}
+$ObjID = $this->{$NextID};
+$this->{$NextID} = $ObjID + 1;
+$this->{$Context}->{refaddr $Var} = $ObjID;
+$this->{$ObjectWriter}->BeginObject(name => $sName, type => ref($Var), id => $ObjID);
+$this->{$State} = STATE_OPENED;
+$this->{$Serializer}->($this,$Var);
+$this->{$ObjectWriter}->EndObject();
+if ($PrevState == STATE_OPENED) {
+$this->{$State} = STATE_COMPLEX;
+} else {
+$this->{$State} = $PrevState;
+}
+return $ObjID;
+}
+sub SetData {
+my ($this,$Data,$Type) = @_;
+die new Exception ('The object should be a scalar value') if ref $Data;
+die new Exception ('Invalid operation') if $this->{$State} != STATE_OPENED;
+$this->{$ObjectWriter}->SetData($Data,$Type);
+$this->{$State} = STATE_DATA;
+return 1;
+}
+sub DefaultSerializer {
+my ($Context, $refObj) = @_;
+if (ref($refObj) eq 'SCALAR') {
+$Context->SetData($$refObj, 'SCALAR');
+} elsif (ref($refObj) eq 'ARRAY') {
+$Context->AddVar('item',$_) foreach @$refObj;
+} elsif (ref($refObj) eq 'HASH') {
+while (my ($key,$value) = each %$refObj) {
+$Context->AddVar($key,$value);
+}
+} elsif (ref($refObj) eq 'REF') {
+$Context->AddVar('ref',$$refObj);
+} else {
+if (ref $refObj and $refObj->UNIVARSAL::can('save')) {
+$refObj->save($Context);
+} else {
+die new Exception('Cant serialize the object of the type: '.ref($refObj));
+}
+}
+return 1;
+}
+package IMPL::Deserialization::Context;
+use base qw(IMPL::Object);
+use IMPL::Class::Property;
+use IMPL::Class::Property::Direct;
+use IMPL::Exception;
+BEGIN {
+# уже десериализованные объекты, хеш, ключ - идентификатор, значение - ссылка.
+private _direct property Context => prop_all;
+# текущий объект. информация для десериализации
+# {
+#   Type => 'typename',
+#   Name => 'object_name',
+#   Data => $Data,
+#   Id => 'object_id'
+# }
+private _direct property CurrentObject => prop_all;
+# стек объектов. сюда добавляются описания объектов по мере встречания новых объектов.
+private _direct property ObjectsPath => prop_all;
+# сюда попадет корень графа объектов
+public _direct property Root => prop_get;
+# создает объект и возвращает на него ссылку
+# ObjectFactory($Type,$DeserializationData,$refSurogate)
+# $Type - имя типа данных
+# $DeserializationData - либо ссылка на массив с данными для десериализации полей,
+# либо скаляр содержащий данные.
+# $refSurogate - ссылка на предварительно созданный, не инициализированный объект.
+# может принимать значение undef
+private _direct property ObjectFactory => prop_all;
+# Создает неинициализированные объекты.
+# SurogateHelper($Type)
+# $Type имя типпа, чей сурогат нужно создать.
+private _direct property SurogateHelper => prop_all;
+}
+sub CTOR {
+my ($this,%args) = @_;
+$this->{$CurrentObject} = undef;
+$this->{$Root} = undef;
+}
+sub OnObjectBegin {
+my ($this,$name,$rhProps) = @_;
+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');
+die new Exception("Trying to create second root object") if not $this->{$CurrentObject} and $this->{$Root};
+if ($rhProps->{'refid'}) {
+my $refObj = $this->{$Context}->{$rhProps->{'refid'}};
+die new Exception("A reference to a not existing object found") if not $refObj;
+my $rhCurrentObj = $this->{$CurrentObject};
+die new Exception("Found a reference to an object as a root of an object's graph") if not $rhCurrentObj;
+if ($rhCurrentObj->{'Data'}) {
+die new Exception("Invalid serializaed data","Plain deserialization data for an object already exist") if not ref $rhCurrentObj->{'Data'};
+push @{$rhCurrentObj->{'Data'}}, $name,$refObj;
+} else {
+$rhCurrentObj->{'Data'} = [$name,$refObj];
+}
+# это затем, что будет вызван OnObjectEnd для объекта, который был простой ссылкой. т.о. мы не нарушим стек
+push @{$this->{$ObjectsPath}},$rhCurrentObj;
+$this->{$CurrentObject} = undef;
+} else {
+push @{$this->{$ObjectsPath}},$this->{$CurrentObject} if $this->{$CurrentObject};
+$this->{$CurrentObject} = {
+Name => $name,
+Type => $rhProps->{'type'} || 'SCALAR',
+Id => $rhProps->{'id'},
+refId => $rhProps->{'refid'}
+};
+$this->{$Context}->{$rhProps->{'id'}} = $this->{$SurogateHelper} ? $this->{$SurogateHelper}->($rhProps->{'type'}) : DefaultSurogateHelper($rhProps->{'type'}) if defined $rhProps->{'id'};
+}
+return 1;
+}
+sub OnObjectData {
+my ($this,$data) = @_;
+my $rhObject = $this->{$CurrentObject};
+die new Exception("Trying to set data for an object which not exists") if not $rhObject;
+die new Exception("Deserialization data already exists for a current object", "ObjectName= $rhObject->{'Name'}") if $rhObject->{'Data'};
+$rhObject->{'Data'} = $data;
+return 1;
+}
+{
+my $AutoId = 0;
+sub OnObjectEnd {
+my ($this,$name) = @_;
+my $rhObject = $this->{$CurrentObject};
+my $rhPrevObject = pop @{$this->{$ObjectsPath}};
+# если текущий объект не определен, а предыдущий - определен, значит текущий - это ссылка
+# просто восстанавливаем предыдущий в текущий и ничего более не делаем
+if ((not defined($rhObject)) && $rhPrevObject) {
+$this->{$CurrentObject} = $rhPrevObject;
+return 1;
+}
+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);
+die new Exception("Trying to close a non existing oject") if not $rhObject;
+my $Data;
+if ($rhObject->{'Id'}) {
+$this->{$Context}->{$rhObject->{'Id'}} = $refObj;
+$Data = $refObj;
+} else {
+if (ref $refObj ne 'SCALAR') {
+$rhObject->{Id} = "auto$AutoId";
+$AutoId ++;
+$this->{$Context}->{$rhObject->{'Id'}} = $refObj;
+$Data = $refObj;
+} else {
+$Data = ${$refObj};
+}
+}
+if (not $rhPrevObject) {
+$this->{$Root} = $Data;
+} else {
+if ($rhPrevObject->{'Data'}) {
+die new Exception("Trying append a reference to an object to the plain data") if not ref $rhPrevObject->{'Data'};
+push @{$rhPrevObject->{'Data'}},$rhObject->{'Name'},$Data;
+} else {
+$rhPrevObject->{'Data'} = [$rhObject->{'Name'},$Data];
+}
+}
+$this->{$CurrentObject} = $rhPrevObject;
+return 1;
+}
+}
+sub _is_class {
+no strict 'refs';
+scalar keys %{"$_[0]::"} ? 1 : 0;
+}
+sub DefaultSurogateHelper {
+my ($Type) = @_;
+if ($Type eq 'SCALAR' or $Type eq 'REF') {
+my $var;
+return \$var;
+} elsif ($Type eq 'ARRAY') {
+return [];
+} elsif ($Type eq 'HASH') {
+return {};
+} else {
+eval "require $Type" unless _is_class($Type);
+if ($Type->UNIVERSAL::can('surrogate')) {
+return $Type->surrogate();
+} else {
+return bless {}, $Type;
+}
+}
+}
+# deserialization context:
+# [
+#   'var_name',value,
+#   ....
+# ]
+sub DefaultFactory {
+my ($Type,$Data,$refSurogate) = @_;
+if ($Type eq 'SCALAR') {
+die new Exception("SCALAR needs a plain data for a deserialization") if ref $Data;
+if ($refSurogate) {
+$$refSurogate = $Data;
+return $refSurogate;
+} else {
+return \$Data;
+}
+} elsif ($Type eq 'ARRAY') {
+die new Exception("Invalid a deserialization context when deserializing ARRAY") if not ref $Data and defined $Data;
+if (not ref $refSurogate) {
+my @Array;
+$refSurogate = \@Array;
+}
+for (my $i = 0; $i < scalar(@{$Data})/2; $i++) {
+push @$refSurogate,$Data->[$i*2+1];
+}
+return $refSurogate;
+} elsif ($Type eq 'HASH') {
+die new Exception("Invalid a deserialization context when deserializing HASH") if not ref $Data and defined $Data;
+if (not ref $refSurogate) {
+$refSurogate = {};
+}
+for (my $i = 0; $i< @$Data; $i+= 2) {
+$refSurogate->{$Data->[$i]} = $Data->[$i+1];
+}
+return $refSurogate;
+} elsif ($Type eq 'REF') {
+die new Exception("Invalid a deserialization context when deserializing REF") if not ref $Data and defined $Data;
+if (not ref $refSurogate) {
+my $ref = $Data->[1];
+return \$ref;
+} else {
+$$refSurogate = $Data->[1];
+return $refSurogate;
+}
+} else {
+eval "require $Type" unless _is_class($Type);
+if ( $Type->UNIVERSAL::can('restore') ) {
+return $Type->restore($Data,$refSurogate);
+} else {
+die new Exception("Don't know how to deserialize $Type");
+}
+}
+}
+package IMPL::Serializer;
+use base qw(IMPL::Object);
+use IMPL::Class::Property;
+use IMPL::Class::Property::Direct;
+use IMPL::Exception;
+BEGIN {
+private _direct property Formatter => prop_all;
+}
+sub CTOR {
+my ($this,%args) = @_;
+$this->Formatter($args{'Formatter'}) or die new Exception("Omitted mandatory parameter 'Formatter'");
+}
+sub Serialize {
+my $this = shift;
+my ($hStream,$Object) = @_;
+my $ObjWriter = $this->Formatter()->CreateWriter($hStream);
+my $Context = new IMPL::Serialization::Context(ObjectWriter => $ObjWriter);
+$Context->AddVar('root',$Object);
+return 1;
+}
+sub Deserialize {
+my $this = shift;
+my ($hStream) = @_;
+my $Context = new IMPL::Deserialization::Context();
+my $ObjReader = $this->Formatter()->CreateReader($hStream,$Context);
+$ObjReader->Parse();
+return $Context->Root();
+}
+1;

Mercurial > pub > Impl

comparison Lib/IMPL/Serialization.pm @ 0:03e58a454b20