view Lib/IMPL/Serialization.pm @ 59:0f3e369553bd

Rewritten property implementation (probably become slower but more flexible) Configuration infrastructure in progress (in the aspect of the lazy activation) Initial concept for the code generator
author wizard
date Tue, 09 Mar 2010 02:50:45 +0300
parents 16ada169ca75
children b0c068da93ac
line wrap: on
line source

package IMPL::Serialization;
use strict;

# 20060222
# ������ ��� ������������ �������� ������
# (�) Sourcer, cin.sourcer@gmail.com
# revision 3 (20090517)


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;