--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Serialization.pm	Tue Jul 14 12:54:37 2009 +0400
@@ -0,0 +1,409 @@
+
+# 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;
\ No newline at end of file