view release on metacpan or  search on metacpan

lib/Treex/PML/Instance/Writer.pm  view on Meta::CPAN

package Treex::PML::Instance::Writer;
{
use 5.008;
use strict;
use warnings;
no warnings qw(recursion);
use Carp;
use Data::Dumper;
use UNIVERSAL::DOES;

BEGIN {
  our $VERSION = '2.29'; # version template
}
use List::Util qw(first);
use Treex::PML::Instance::Common qw(:diagnostics :constants);
use Treex::PML::Schema;
use Treex::PML::IO qw(open_backend close_backend rename_uri);
use Encode;

my (
  %handlers,
  %src,
  %handler_cache,
  @handler_cache,
 );

# TODO:
# - test inline schemas
# - content_pattern and cdata validation on save
# - mixed content
# - decorate

our $CACHE_HANDLERS=1;
our $MAX_SCHEMA_CACHE_SIZE=50;

our $VALIDATE_CDATA=0;
our $SAVE_REFFILES = 1;
our $WITH_TREES = 1;
our $KEEP_KNIT = 0;
our $WRITE_SINGLE_LM = 0;
our $WRITE_SINGLE_CHILDREN_LM = 0;
our $INDENT = 2;

require Treex::PML;

sub _get_handlers_cache_key {
  my ($schema)=@_;
  my $key="$schema"; $key=~s/.*=//; # strip class
  return
    [
      $key,
      join ',',
      $key,
      $INDENT || 0,
      $VALIDATE_CDATA || 0,
      $SAVE_REFFILES || 0,
      $WITH_TREES || 0,
      $WRITE_SINGLE_LM || 0,
      $KEEP_KNIT || 0,
      $WRITE_SINGLE_CHILDREN_LM || 0,
];
}

sub get_cached_handlers {
  my ($key)=@_;
  my $subkey = $key->[1];
  my $cached = $handler_cache{ $key->[0] }{ $subkey };
  if ($cached and $handler_cache[-1][1] ne $subkey) {
    # move the last retrieved schema to the end of the queue
    @handler_cache = ((grep { $_->[1] ne $subkey } @handler_cache),$key);
  }
  return $cached;
}

sub cache_handlers {
  my ($key,$handlers)=@_;
  my $subkey = $key->[1];
  push @handler_cache,$key;
  $handler_cache{$key->[0]}{$subkey} = $handlers;
  if (@handler_cache > $MAX_SCHEMA_CACHE_SIZE) {
    my $del = shift @handler_cache;
    delete $handler_cache{ $del->[0] }{ $del->[1] };
  }
}

sub forget_schema {
  my ($schema)=@_;
  delete $handler_cache{ $schema }; # delete also from the handler cache
  @handler_cache = grep { $_->[0] ne $schema } @handler_cache;
}

sub _indent {
  if ($INDENT>=0) {
    return q{"\n".('}.(' ' x $INDENT).q{' x $indent_level).}
  } else {
    return q()
  }
}
sub _indent_inc {
  if ($INDENT>0) {
    return q`
  $indent_level++;`;
  } else {
    return q()
  }
}
sub _indent_dec {
  if ($INDENT>0) {
    return q`
  $indent_level--;`;
  } else {
    return q()
  }
}

sub save {
  my ($ctxt,$opts)=@_;
  my $fh = $opts->{fh};
  local $VALIDATE_CDATA=$opts->{validate_cdata} if
    exists $opts->{validate_cdata};

  $ctxt->set_filename($opts->{filename}) if $opts->{filename};
  my $href = $ctxt->{'_filename'};

  $fh=\*STDOUT if ($href eq '-' and !$fh);
  my $config = $opts->{config};
  if ($config and ref(my $load_opts = $config->get_data('options/save'))) {
    $opts = {%$load_opts, %$opts};
  }

  local $KEEP_KNIT = 1 if $opts->{keep_knit};
  local $WRITE_SINGLE_LM = 1 if $opts->{write_single_LM};
  local $WRITE_SINGLE_CHILDREN_LM = 1 if $opts->{write_single_children_LM};
  local $INDENT = $opts->{indent} if defined $opts->{indent};
  unless ($fh) {
    if (defined($href) and length($href)) {
      eval {
        rename_uri($href,$href."~") unless $href=~/^ntred:/;
      };
      my $ok = 0;
      my $res;
      eval {
        $fh = open_backend($href,'w')
          || die "Cannot open $href for writing: $!";
        if ($fh) {
          binmode $fh;
          $res = $ctxt->save({%$opts, fh=> $fh});
          close_backend($fh);
          $ok = 1;
        }
      };
      unless ($ok) {
        my $err = $@;
        eval {
          rename_uri($href."~",$href) unless $href=~/^ntred:/;
        };
        die($err."$@\n") if $err;
      }
      return $res;
    } else {
      die("Usage: $ctxt->save({filename=>...,[fh => ...]})");
    }
  }
  $ctxt->{'_refs_save'} ||= $opts->{'refs_save'};
  binmode $fh if $fh;

  my $transform_id = $ctxt->{'_transform_id'};
  my ($out_xsl_href,$out_xsl,$orig_fh);
  my $xsl_source='';
  if ($config and defined $transform_id and length  $transform_id) {
    my $transform = $config->lookup_id( $transform_id );
    if ($transform) {
      ($out_xsl) = $transform->{'out'};
      if ($out_xsl->{'type'} ne 'xslt') {
        die(__PACKAGE__.": unsupported output transformation $transform_id (only type='xslt') transformations are supported)");
      }
      $out_xsl_href = URI->new(Encode::encode_utf8($out_xsl->get_member('href')));
      $out_xsl_href = Treex::PML::ResolvePath($config->{_filename}, $out_xsl_href, 1);
      unless (defined $out_xsl_href and length $out_xsl_href) {
        die(__PACKAGE__.": no output transformation defined for $transform_id");

lib/Treex/PML/Instance/Writer.pm  view on Meta::CPAN

        $sub .= q`
         } elsif (@$data==1 and defined($data->[0]) and !(UNIVERSAL::isa($data->[0],'HASH') and keys(%{$data->[0]})==0)) {
           print $out '>' if defined $tag and !length $tag;
           $handlers{ '`.$cpath.q`' }->($tag || 'LM',$data->[0]);`;
      }
      $sub .= q`
         } else {
           print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;`._indent_inc().q`
           for $v (@$data) {
             if (defined $v and (ref $v or length $v)) {
               $handlers{ '`.$cpath.q`' }->('LM',$v);
             } else {
               print $out `._indent().q`"<LM/>";
             }
           }`._indent_dec().q`
           print $out `._indent().q`"</$tag>" if defined $tag and length $tag;
         }
       }`;
      $src{$src}=$sub;
      $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_ALT_DECL) {
      my $cdecl = $decl->get_content_decl;
      my $cpath = $cdecl->get_decl_path;
      $cpath=~s/^!//;
      my $src = $schema_name.'__generated_write_alt@'.$path;
      $src=~y{/}{@};
        # TODO: check it's an Alt
      my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
       sub {
         my ($tag,$data)=@_;
         unless (defined $data) {
            print $out defined $tag ? '/>' : '>' if !$tag;
            return;
         }
         if (!UNIVERSAL::DOES::does($data, 'Treex::PML::Alt')) {
           print $out '>' if defined $tag and !length $tag;
           $handlers{ '`.$cpath.q`' }->($tag || 'AM',$data);
         } elsif (@$data==1) {
           print $out '>' if defined $tag and !length $tag;
           $handlers{ '`.$cpath.q`' }->($tag || 'AM',$data->[0]);
         } elsif (@$data==0) {
           print $out defined $tag ? '/>' : '>' if !$tag;
           return;
         } else {
           my $v;
           print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;`._indent_inc().q`
           for $v (@$data) {
             if (defined $v and (ref $v or length $v)) {
               $handlers{ '`.$cpath.q`' }->('AM',$v);
             } else {
               print $out `._indent().q`"<AM/>";
             }
           }`._indent_dec().q`
           print $out `._indent().q`"</$tag>" if defined $tag and length $tag;
         }
       }`;
      $src{$src}=$sub;
      $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_CDATA_DECL) {
      # TODO: CDATA FORMAT VALIDATION
      my $src = $schema_name.'__generated_write_cdata@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
       sub {
         my ($tag,$data)=@_;
         print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;
         if (defined $data and length $data) {
           $data=~s/&/&amp;/g;$data=~s/</&lt;/g;$data=~s/\]\]>/]]&gt;/g;
           print $out $data;
         }
         print $out "</$tag>" if defined $tag and length $tag;
       }`;
      $src{$src}=$sub;
      $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_CHOICE_DECL) {
      my $value_hash = $decl->{value_hash};
      unless ($value_hash) {
        $value_hash={};
        @{$value_hash}{@{$decl->{values}}}=();
        $decl->{value_hash}=$value_hash;
      }
      my $src = $schema_name.'__generated_write_choice@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
       sub {
         my ($tag,$data)=@_;
         print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;
         if (defined $data and length $data) {
           warn("Value: '$data' not allowed for choice type '`.$path.q`'; writing anyway!") if !exists $value_hash->{$data};
           $data=~s/&/&amp;/g;$data=~s/</&lt;/g;
           print $out $data;
         }
         print $out "</$tag>" if defined $tag and length $tag;
       }`;
      $src{$src}=$sub;
      $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_CONSTANT_DECL) {
      my $value = quotemeta($decl->{value});
      my $src = $schema_name.'__generated_write_choice@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 1 ".pml_compile.d/`.$src.q`"
       sub {
         my ($tag,$data)=@_;
         print $out (length($tag) ? `._indent().q`"<$tag>" : '>') if defined $tag;
         if (defined $data and length $data) {
           warn("Invalid value '$data' in a constant type '`.$path.q`', should be '`.$value.q`'; writing anyway!") if $data ne "`.$value.q`";
           $data=~s/&/&amp;/g;$data=~s/</&lt;/g;
           print $out $data;
         }
         print $out "</$tag>" if defined $tag and length $tag;
       }`;
      $src{$src}=$sub;
      $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
    }
    #  print "@_\n";
  });
  $schema->for_each_decl(
    sub {
      my ($decl)=@_;
      my $decl_type=$decl->get_decl_type;
      if ($decl_type == PML_ATTRIBUTE_DECL ||