view Lib/IMPL/Serialization/XmlFormatter.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 dc1da0389db7
line wrap: on
line source

package IMPL::Serialization::XmlObjectWriter;
use strict;

use base qw(IMPL::Object);
use IMPL::Class::Property;
use IMPL::Class::Property::Direct;

use IMPL::Serialization;
use XML::Writer;
use IMPL::Exception;

sub CONTAINER_EMPTY () { 1 }
sub CONTAINER_NORMAL () { 2 }

BEGIN {
  public _direct property Encoding => prop_all;
  public _direct property hOutput => prop_all;
  public _direct property IdentOutput => prop_all;
  
  private _direct property CurrentObject => prop_all;
  private _direct property ObjectPath => prop_all;
  private _direct property XmlWriter => prop_all;
  private _direct property IdentLevel => prop_all;
  private _direct property IdentNextTag => prop_all;
}

sub new {
  my $class = shift;
  my $self = bless {}, ref($class) || $class;
  $self->CTOR(@_);
  return $self;
}

sub CTOR {
  my $this = shift;
  my %args = @_;
  $this->{$hOutput} = $args{'hOutput'};
  $this->{$Encoding} = $args{'Encoding'};
  $this->{$CurrentObject} = undef;
  $this->{$IdentOutput} = $args{'IdentOutput'};
  $this->{$IdentLevel} = 0;
  $this->{$IdentNextTag} = 0;
  #$this->{$ObjectPath} = [];
  return 1;
}

sub BeginObject {
  my $this = shift;
  my %args = @_;
  
  if (not $this->{$CurrentObject}) {
    my $xmlWriter = new XML::Writer(OUTPUT => $this->{$hOutput}, ENCODING => $this->{$Encoding});
    $this->{$XmlWriter} = $xmlWriter;
    $xmlWriter->xmlDecl();
  }
  
  push @{$this->{$ObjectPath}},$this->{$CurrentObject} if $this->{$CurrentObject};
  
  my %ObjectProperties = %args;
  delete $ObjectProperties{'name'};
  delete $args{'container_type'};

  $this->{$CurrentObject} = \%ObjectProperties;

  my $tagname;  
  if (_CheckName($args{'name'})) {
    $tagname = $args{'name'};
  } else {
    $tagname = 'element';
    $ObjectProperties{'extname'} = $args{'name'};
  }
  
  if ($args{'refid'}) {
    $this->{$XmlWriter}->characters("\n" . ('  ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag};
    $this->{$XmlWriter}->emptyTag($tagname,%ObjectProperties);
    $ObjectProperties{'container_type'} = CONTAINER_EMPTY;
  } else {
    $this->{$XmlWriter}->characters("\n" . ('  ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag};
    $this->{$XmlWriter}->startTag($tagname,%ObjectProperties);
    $ObjectProperties{'container_type'} = CONTAINER_NORMAL;
  }
  
  $this->{$IdentLevel} ++;
  $this->{$IdentNextTag} = $this->{$IdentOutput};
  
  return 1;
}

sub EndObject {
  my $this = shift;
  
  my $hCurrentObject = $this->{$CurrentObject} or return 0;
  
  $this->{$IdentLevel} --;
    
  if ( $hCurrentObject->{'container_type'} != CONTAINER_EMPTY ) {
    $this->{$XmlWriter}->characters("\n" . ('  ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag};
    $this->{$XmlWriter}->endTag();
  }
  
  $this->{$IdentNextTag} = $this->{$IdentOutput};
  
  $this->{$CurrentObject} = pop @{$this->{$ObjectPath}} if exists $this->{$ObjectPath};
  $this->{$XmlWriter} = undef if (not $this->{$CurrentObject});
  
  return 1;
}

sub SetData {
  my $this = shift;
  #my $hCurrentObject = $this->{$CurrentObject} or return 0;
  
  if ($this->{$CurrentObject}->{'container_type'} == CONTAINER_NORMAL) {
    $this->{$XmlWriter}->characters($_[0]) if defined $_[0];
    $this->{$IdentNextTag} = 0;
    return 1;
  } else {
    return 0;
  }
}

sub _CheckName {
  return 0 if not $_[0];
  return $_[0] =~ /^(_|\w|\d)+$/;
}

package IMPL::Serialization::XmlObjectReader;
use base qw(XML::Parser);

sub new {
  my $class = shift;
  my %args = @_;
  die new Exception("Handler parameter is reqired") if not $args{'Handler'};
  die new Exception("Handler parameter must be a reference") if not ref $args{'Handler'};
  
  #my $this = $class->SUPER::new(Style => 'Stream', Pkg => 'Serialization::XmlObjectReader', 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } );
  my $this = $class->SUPER::new(Handlers => { Start => \&StartTag, End => \&EndTag, Char => \&Text} , 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } );
  return $this;
}

sub Parse {
  my $this = shift;
  $this->parse($this->{'Non-Expat-Options'}->{'hInput'});
  return 1;
}

sub StartTag {
  my $this = shift;
  my $name = shift;
  my %Attr = @_;
  $name = $Attr{'extname'} if defined $Attr{'extname'};
  $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectBegin($name,\%Attr);
  return 1;
}

sub EndTag {
  my ($this,$name) = @_;
  $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectEnd($name);
  return 1;
}

sub Text {
  my ($this) = shift;
  $_ = shift;
  return 1 if $this->{'Non-Expat-Options'}->{'SkipWhitespace'} and /^\n*\s*\n*$/;
  $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectData($_);
  return 1;
}

package IMPL::Serialization::XmlFormatter;
use base qw(IMPL::Object);

use IMPL::Class::Property;
use IMPL::Class::Property::Direct;

BEGIN {
  public _direct property Encoding => prop_all;
  public _direct property SkipWhitespace => prop_all;
  public _direct property IdentOutput => prop_all;
}

sub CTOR {
  my ($this,%args) = @_;
  
  $this->Encoding($args{'Encoding'} || 'utf-8');
  $this->SkipWhitespace($args{'SkipWhitespace'});
  $this->IdentOutput($args{'IdentOutput'});
  
  return 1;
}

sub CreateWriter {
  my ($this,$hStream) = @_;
  return new IMPL::Serialization::XmlObjectWriter(Encoding =>$this->Encoding() , hOutput => $hStream, IdentOutput => $this->IdentOutput());
}

sub CreateReader {
  my ($this,$hStream,$refHandler) = @_;
  return new IMPL::Serialization::XmlObjectReader(hInput => $hStream, Handler => $refHandler, SkipWhitespace => $this->SkipWhitespace());
}

1;