File Coverage

blib/lib/Treex/PML/Instance.pm

Criterion	Covered	Total	%
statement	26	28	92.8
branch			n/a
condition			n/a
subroutine	10	10	100.0
pod			n/a
total	36	38	94.7

package Treex::PML::Instance;

use 5.008;
use strict;
use warnings;
use Carp;
use Cwd;

BEGIN {

require Exporter;
import Exporter qw(import);

}

use Scalar::Util qw(weaken blessed);
use UNIVERSAL::DOES;
use Treex::PML::Instance::Common qw(:all);
use Treex::PML::Schema;
use Encode;
use File::Spec;
use URI;
use URI::file;
our $DEFAULT_ENCODING = 'utf-8';

BEGIN {

=begin comment

 TODO

  Note: correct writing with XSLT requires XML::LibXML >= 1.59 (!!!)

 (GENERAL):

  - improve reading/writing trees (use the live object)
    Postponing because:
       1/ sequences of tree/no-tree objects are problematic
       2/ changing this would break binary compatibility

  - Treex::PML:
       find_role_in_data,
       traverse_data($node, $decl, sub($data,$decl,$decl_resolved))

  - readas DOM => readas PML, where #KNITting means pointing to the same data (if possible).
    test implementation: breaks old Undo/Redo, but ok with the new "object-preserving" one

  (XSLT):

  - support for external xslt processors (maybe a common wrapper)
  - with LibXSLT, cache the parsed stylesheets

  DONE:

  - hash by #ID into appData('id-hash')/{'id-hash'} (knitted instances could be hashed with prefix#,
    knitted-knitted instances with prefix1#prefix2#...)
    (this is temporary)

=end comment

=cut

}

our %EXPORT_TAGS = (
  'functions' => [ qw( get_data set_data count_matches for_each_match get_all_matches ) ],
  'constants' => $Treex::PML::Instance::Common::EXPORT_TAGS{constants},
  'diagnostics' => $Treex::PML::Instance::Common::EXPORT_TAGS{diagnostics},
);
$EXPORT_TAGS{'all'} = [ @{ $EXPORT_TAGS{'constants'} },
                        @{ $EXPORT_TAGS{'diagnostics'} },
                        @{ $EXPORT_TAGS{'functions'} },
                        qw( $DEBUG )
                      ];

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(  );
our $VERSION = '2.22'; # version template

BEGIN {
require Treex::PML::IO;
require Treex::PML;


# FIELDS:
use fields qw(
    _schema
    _schema-url
    _schema-inline
    _types
    _dom
    _root
    _parser
    _writer
    _filename
    _transform_id
    _status
    _readas-trees
    _references
    _refnames
    _ref
    _ref-index
    _pml_trees_type
    _no_read_trees
    _no_references
    _no_knit
    _selected_references
    _selected_references_ids
    _selected_knits
    _selected_knits_ids
    _trees
    _pml_prolog
    _pml_epilog
    _id-hash
    _log
    _id_prefix
    _trees_written
    _refs_save
    _save_flags
    _pi
   );

} # BEGIN

use Treex::PML::Instance::Reader;
use Treex::PML::Instance::Writer;

# PML Instance File
sub get_filename {
  my $filename= $_[0]->{'_filename'};
  if (blessed($filename) and $filename->isa('URI')
      and $filename->scheme eq 'file') {
    return $filename->file;
  }
  return $filename;
}
sub get_url {
  my $filename= $_[0]->{'_filename'};
  if ($filename and not (blessed($filename) and $filename->isa('URI'))) {
    return Treex::PML::IO::make_URI($filename);
  }
  return $filename;
}

sub set_filename {
  $_[0]->{'_filename'} = Treex::PML::IO::make_abs_URI($_[1]); # 1K faster than cwd
}
sub get_transform_id  {  $_[0]->{'_transform_id'}; }
sub set_transform_id  {  $_[0]->{'_transform_id'} = $_[1]; }

# Schema
sub schema            {  $_[0]->{'_schema'} }
*get_schema = \&schema;
sub set_schema        {  $_[0]->{'_schema'} = $_[1] }
sub get_schema_url    {  $_[0]->{'_schema-url'} }
sub set_schema_url    {  $_[0]->{'_schema-url'} = $_[1]; }

# Data
sub get_root          {  $_[0]->{'_root'}; }
sub set_root          {  $_[0]->{'_root'} = $_[1]; }
sub get_trees         {  $_[0]->{'_trees'}; }
#sub set_trees        {  $_[0]->{'_trees'} = $_[1]; }
sub get_trees_prolog  {  $_[0]->{'_pml_prolog'}; }
#sub set_trees_prolog {  $_[0]->{'_pml_prolog'} = $_[1]; }
sub get_trees_epilog  {  $_[0]->{'_pml_epilog'}; }
#sub set_trees_epilog {  $_[0]->{'_pml_epilog'} = $_[1]; }
sub get_trees_type    {  $_[0]->{'_pml_trees_type'}; }
#sub set_trees_type   {  $_[0]->{'_pml_trees_type'} = $_[1]; }

# References
sub get_references_hash {
  return ($_[0]->{'_references'}||={});
}
sub set_references_hash {  $_[0]->{'_references'} = $_[1]; }
sub get_ref_ids_by_name {
  my ($self,$name)=@_;
  my $refs = $self->get_refname_hash->{$name};
  return ref($refs) ? @$refs : ($refs);
}
sub get_refs_by_name {
  my ($self,$name)=@_;
  return map {$self->get_ref($_)} $self->get_ref_ids_by_name;
}
sub get_refname_hash {
  return ($_[0]->{'_refnames'}||={});
}
sub set_refname_hash {  $_[0]->{'_refnames'} = $_[1]; }
sub get_ref {
  my ($self,$id)=@_;
  my $refs = $self->{'_ref'};
  return $refs ? $refs->{$id} : undef;
}
sub set_ref {
  my ($self,$id,$obj)=@_;
  my $refs = $self->{'_ref'};
  $self->{'_ref'} = $refs = {} unless ($refs);
  return $refs->{$id}=$obj;
}

# Status=1 (if parsed fine)
sub get_status  {  $_[0]->{'_status'}; }
#sub set_status {  $_[0]->{'_status'} = $_[1]; }

sub get_reffiles {
  my ($ctxt)=@_;
  my $references = [$ctxt->{'_schema'}->get_named_references];
  my @refs;
  if ($references) {
    foreach my $reference (@$references) {
      my $refids = $ctxt->{'_refnames'}->{$reference->{name}};
      if ($refids) {
        foreach my $refid (ref($refids) ? @$refids : ($refids)) {
          my $href = $ctxt->{'_references'}->{$refid};
          if ($href) {
            _debug("Found '$reference->{name}' as $refid# = '$href'");
            push @refs,{
              readas => $reference->{readas},
              name => $reference->{name},
              id => $refid,
              href => $href
             };
          } else {
            _die("No href for $refid# ($reference->{name})")
          }
        }
      } else {
        _warn("Didn't find any reference to '".$reference->{name}."'\n");
      }
    }
  }
  return @refs;
}

sub read_reffiles {
  my ($ctxt,$opts) = @_;
  foreach my $ref ($ctxt->get_reffiles()) {
    my $id = $ref->{id};
    my $selected = $ctxt->{'_selected_references_ids'}{$id};
    next if (defined($selected) ? $selected==0 : $ctxt->{'_no_references'});
    my $readas = $ref->{readas};
    if (defined $readas) {
      if ($readas eq 'dom') {
        $ctxt->readas_dom($id,$ref->{href},$opts);
      } elsif($readas eq 'trees') {
        #  when translating to Treex::PML::Document,
      #  push to fs-require [$id,$ref->{href}];
      } elsif($readas eq 'pml') {
        $ctxt->readas_pml($id,$ref->{href},$opts);
      } elsif (length($readas)) {
        _warn("Ignoring references with unknown readas method: '$readas' for reffile id='$id', href='$ref->{href}'\n");
      }
    }
  }
}

sub readas_pml {
  my ($ctxt,$refid,$href,$opts)=@_;
  # embed PML documents
  my $ref_data;
  _debug("readas_pml: $refid => $href");
  my $pml = Treex::PML::Instance->load({
    filename => $href,
    no_knit => $ctxt->{_no_knit},
    selected_knits => $ctxt->{_selected_knits},
    no_references => $ctxt->{_no_references},
    selected_references => $ctxt->{_selected_references},
    ($opts ? %$opts : ()),
  });
  $ctxt->{'_ref'} ||= {};
  $ctxt->{'_ref'}->{$refid}=$pml;
  $ctxt->{'_ref-index'} ||= {};
  weaken( $ctxt->{'_ref-index'}->{$refid} = $pml->{'_id-hash'} );
  1;
}

# $ctxt, $refid, $href
sub readas_dom {
  my ($ctxt,$refid,$href,$opts)=@_;
  # embed DOM documents
  my $ref_data;
  # if ($opts and $opts->{use_resources}) {
  #   $href = Treex::PML::FindInResourcePaths($href);
  # }

  my ($local_file,$remove_file) = Treex::PML::IO::fetch_file($href);
  my $ref_fh = Treex::PML::IO::open_uri($local_file);
  _die("Cannot open $href for reading") unless $ref_fh;
  _debug("readas_dom: $refid => $href");
  my $parser = $ctxt->{'_parser'} || $ctxt->_xml_parser();
  if ($ref_fh){
    eval {
      $ref_data = $parser->parse_fh($ref_fh, $href);
    };
    _die("Error parsing $href $ref_fh $local_file ($@)") if $@;
    $ref_data->setBaseURI($href) if $ref_data and $ref_data->can('setBaseURI');;
    $parser->process_xincludes($ref_data);
    Treex::PML::IO::close_uri($ref_fh);
    $ctxt->{'_ref'} ||= {};
    $ctxt->{'_ref'}->{$refid}=$ref_data;
    $ctxt->{'_ref-index'} ||= {};
    $ctxt->{'_ref-index'}->{$refid}=_index_by_id($ref_data);
    if ($href ne $local_file and $remove_file) {
      local $!;
      unlink $local_file || _warn("couldn't unlink tmp file $local_file: $!\n");
    }
  } else {
    if ($href ne $local_file and $remove_file) {
      local $!;
      unlink $local_file || _warn("couldn't unlink tmp file $local_file: $!\n");
    }
    _die("Couldn't open '".$href."': $!");
  }
  1;
}

sub _xml_parser {
  my ($self,$opts) = @_;
  my $parser = XML::LibXML->new();
  $parser->keep_blanks(0);
  $parser->line_numbers(1);
  $parser->load_ext_dtd(0);
  $parser->validation(0);
  if (ref($opts) and $parser->can('set_options')) {
    $parser->set_options($opts);
  }
  return $parser;
}

###################################
# CONSTRUCTOR
####################################

sub new {
  my $class = shift;
  _die('Usage: ' . __PACKAGE__ . '->new()') if ref($class);
  return fields::new($class);
}



###################################
# LOAD
###################################

sub load {
  return &Treex::PML::Instance::Reader::load;
}

sub save {
  return &Treex::PML::Instance::Writer::save;
}

sub lookup_id {
  my ($ctxt,$id)=@_;
  my $hash = $ctxt->{'_id-hash'} ||= {};
  return $hash->{ $id };
}

sub hash_id {
  my ($ctxt,$id,$object,$check_uniq) = @_;
  return unless defined($id) and length($id);
  my $prefix = $ctxt->{'_id_prefix'} || '';
  $id = $prefix . $id;
  my $hash = $ctxt->{'_id-hash'} ||= {};
  if ($check_uniq) { # and $prefix eq ''
    my $current = $hash->{$id};
    if (defined $current and $current != $object) {
      _warn("Duplicated ID '$id'");
    }
  }
  if (ref($object)) {
    weaken( $hash->{$id} = $object );
  } else {
    $hash->{$id} = $object;
  }
}

sub _index_by_id {
  my ($dom) = @_;
  my %index;
  $dom->indexElements;
  for my $node (@{$dom->findnodes('//*/@*[name()="id" or name()="xml:id"]')}) {
    $index{ $node->value }=$node->ownerElement;
  }
  return \%index;
}

##########################################
# Validation
#########################################

sub validate_object {
  my ($ctxt, $object, $type, $opts)=@_;
  $type->validate_object($object,$opts);
}

##########################################
# Data pulling
#########################################


sub get_data {
  my ($node,$path, $strict) = @_;
  if (UNIVERSAL::DOES::does($node,'Treex::PML::Instance')) {
    $node = $node->get_root;
  }
  my $val = $node;
  if (!defined $path) {
    carp("Treex::PML::Instance::get_data : undefined attribute path!");
    return;
  }
  for my $step (split /\//, $path) {
    next if $step eq '.';
    my $is_list = UNIVERSAL::DOES::does($val,'Treex::PML::List');
    if ($is_list or UNIVERSAL::DOES::does($val,'Treex::PML::Alt')) {
      if ($step =~ /^\[([-+]?\d+)\]/) {
        $val =
          $1>0 ? $val->[$1-1] :
          $1<0 ? $val->[$1] : undef;
      } elsif ($strict) {
#        warn "Can't follow attribute path '$path' (step '$step')\n";
        return; # ERROR
      } else {
        $val = $val->[0];
        redo unless $step eq ($is_list ? LM : AM);
      }
    } elsif (UNIVERSAL::DOES::does($val,'Treex::PML::Seq')) {
      if ($step =~ /^\[([-+]?\d+)\](.*)/) {
        $val =
          $1>0 ? $val->elements_list->[$1-1] :
          $1<0 ? $val->elements_list->[$1] : undef; # element
        if ($val) {
          if (defined $2 and length $2) { # optional name test
            return if $val->[0] ne $2; # ERROR
          }
          $val = $val->[1]; # value
        }
      } elsif ($step =~ /^([^\[]+)(?:\[([-+]?\d+)\])?/) {
        my $i = $2;
        $val = $val->values($1);
        if ($i ne q{}) {
          $val = $i>0 ? $val->[$i-1] :
                 $i<0 ? $val->[$i] : undef;
        }
      } else {
        return; # ERROR
      }
    } elsif (ref($val)) {
      $val = $val->{$step};
    } elsif (defined($val)) {
#      warn "Can't follow attribute path '$path' (step '$step')\n";
      return; # ERROR
    } else {
      return undef;
    }
  }
  return $val;
}

sub get_all {
  my ($node,$path) = @_;
  if (UNIVERSAL::DOES::does($node,'Treex::PML::Instance')) {
    $node = $node->get_root;
  }
  my @vals = ($node);
  my $val;
  my $redo=0;
  my $dot;
  for my $step (ref($path) ? @$path : (split /\//, $path)) {
    $dot= ($step eq '.');
    next if $dot;
    $redo=0;
    @vals = map {
      $val=$_;
      my $is_list = UNIVERSAL::DOES::does($val,'Treex::PML::List');
      if ($is_list or UNIVERSAL::DOES::does($val,'Treex::PML::Alt')) {
        if ($step =~ /^\[([-+]?\d+)\]/) {
          $1>0 ? $val->[$1-1] :
            $1<0 ? $val->[$1] : ();
        } else {
          $redo=1 unless $step eq ($is_list ? 'LM' : 'AM');
          @$val
        }
      } elsif (UNIVERSAL::DOES::does($val,'Treex::PML::Seq')) {
        #        grep { $_->[0] eq $step } @{$val->[0]}
        if ($step =~ /^\[([-+]?\d+)\](.*)/) {
          $val =
            $1>0 ? $val->elements_list->[$1-1] :
            $1<0 ? $val->elements_list->[$1] : undef; # element
          $val ?
            (defined $2 and length $2) ?
              ($val->[0] eq $2) ? ($val->[1]) : ()
            : $val->[1]
          :()
        } elsif ($step =~ /^([^\[]+)(?:\[([-+]?\d+)\])?/) {
          my $i = $2;
          $val = $val->values($1);
          if (defined $i and length $i) {
             $i>0 ? $val->[$i-1] :
             $i<0 ? $val->[$i] : ();
          } else {
            @$val
          }
        } else { () }
      } elsif (ref($val)) {
        ($val->{$step});
      } else {
        ()
      }
    } @vals;
    redo if $redo;
  }
  return @vals if $dot; # a path may end with a /. to prevent expanding trailing lists and alts
  return map { (UNIVERSAL::DOES::does($_,'Treex::PML::List') or UNIVERSAL::DOES::does($_,'Treex::PML::Alt')) ? __expand_list_alt($_) : ($_) } @vals;
}
sub __expand_list_alt {
  return map { (UNIVERSAL::DOES::does($_,'Treex::PML::List') or UNIVERSAL::DOES::does($_,'Treex::PML::Alt')) ? _expand_list_alt($_) : ($_) } @{$_[0]};
}

sub set_data {
  my ($node,$path, $value, $strict) = @_;
  if (UNIVERSAL::DOES::does($node,'Treex::PML::Instance')) {
    $node = $node->get_root;
  }
  my $val = $node;
  my @steps = split /\//, $path;
  while (@steps) {
    my $step = shift @steps;
    if (UNIVERSAL::DOES::does($val,'Treex::PML::List') or UNIVERSAL::DOES::does($val,'Treex::PML::Alt')) {
      if ($step =~ /^\[([-+]?\d+)\]/) {
        if (@steps) {
          $val =
            $1>0 ? $val->[$1-1] :
            $1<0 ? $val->[$1] : undef;
        } else {
          return
            $1>0 ? ($val->[$1-1]=$value) :
            $1<0 ? ($val->[$1]=$value) : undef;
        }
      } elsif ($strict) {
        my $msg = "Can't follow attribute path '$path' (step '$step')";
        croak $msg if ($strict==2);
        warn $msg."\n";
        return; # ERROR
      } else {
        if (@steps) {
          $val = $val->[0]{$step};
        } else {
          $val->[0]{$step} = $value;
          return $value;
        }
      }
    } elsif (UNIVERSAL::DOES::does($val,'Treex::PML::Seq')) {
      if ($step =~ /^\[([-+]?\d+)\](.*)/) {
        my $i = $1;
        my $el = $i>0 ? $val->elements_list->[$i-1] :
                 $i<0 ? $val->elements_list->[$i] : undef; # element
        if (defined $el and defined $2 and length $2 and $el->[0] ne $2) { # optional name test
          my $msg = "Can't follow attribute path '$path' (step '$step')";
          croak $msg if ($strict==2);
          warn $msg."\n";
          return; # ERROR
        }
        if (@steps) {
          $val = $el->[1];
        } else {
          if (UNIVERSAL::DOES::does($value,'Treex::PML::Seq::Element')) {
            $val = $val->elements_list;
            return
              $i>0 ? ($val->[$i-1]=$value) :
              $i<0 ? ($val->[$i]=$value) : undef;
          } elsif (ref $val->[$i-1]) {
            $el->[1]=$value;
            return $value;
          } else {
            my $msg = "Can't follow attribute path '$path' (no sequence element found at step '$step')";
            croak $msg if ($strict==2);
            warn $msg."\n";
            return; # ERROR
          }
        }
      } elsif ($step =~ /^([^\[]+)(?:\[([-+]?\d+)\])?/) {
        my $i = $2;
        $val = $val->values($1);
        unless (@steps) {
          $val = $1>0 ? $val->[$1-1] :
                 $1<0 ? $val->[$1] : undef;
          if (defined $val) {
            if (UNIVERSAL::DOES::does($value,'Treex::PML::Seq::Element')) {
              $val->[0]=$value->[0];
              $val->[1]=$value->[1];
              return $val;
            } else {
              $val->[1]=$value;
              return $value;
            }
          } else {
            my $msg = "Can't follow attribute path '$path' (no sequence element found at step '$step')";
            croak $msg if ($strict==2);
            warn $msg."\n";
            return; # ERROR
          }
        }
      } else {
        return; # ERROR
      }
    } elsif (ref($val)) {
      if (@steps) {
        if (!defined($val->{$step}) and $steps[0]!~/^\[/) {
          $val->{$step}=Treex::PML::Factory->createStructure();
        }
        $val = $val->{$step};
      } else {
        $val->{$step} = $value;
        return $value;
      }
    } elsif (defined($val)) {
      my $msg = "Can't follow attribute path '$path' (step '$step')";
      croak $msg if ($strict==2);
      warn $msg."\n";
      return; # ERROR
    } else {
      return '';
    }
  }
  return;
}



sub __match_path {
  my ($match_paths, $step)=@_;
  my @r;
  my $s = $step;
  $s =~ s/^\[\d+\]//;
  foreach my $m (@$match_paths) {
    my ($m_step,@rest) = @{$m->[0]};
    if (defined $m_step and length($m_step)==0) {
      # handle //
      push @r,$m, [\@rest=>$m->[1]];
    } elsif ($m_step eq $step or $m_step eq '*') {
      push @r,[\@rest=>$m->[1]];
    } elsif ($m_step !~ /^\[/) {
      if (!length($s)) {
        push @r,$m;
      } elsif ($s eq $m_step) {
        push @r,[\@rest=>$m->[1]];
      }
    }
  }
  return \@r;
}

sub __split_path {
  my @p =  split m{/}, $_[0];
  if (@p>0 and length($p[0])==0) { shift @p; }
  return \@p;
}

sub for_each_match {
  my ($obj,$paths,$opts) = @_;
  $opts||={};
  my @match_paths;
  if (UNIVERSAL::isa($paths,'HASH')) {
    @match_paths = map { [ __split_path($_) => $paths->{$_} ] } keys %$paths;
  } else {
    croak("Usage: \$pml->for_each_match( { path1 => callback1, path2 => callback2,...} )\n".
          "   or: Treex::PML::Instance::for_each_match( \$obj, { path1 => callback1, ... } )\n");
  }
  my $type;
  if (UNIVERSAL::DOES::does($obj,'Treex::PML::Instance')) {
    if (exists $opts->{type}) {
      $type = $opts->{type}
    } else {
      $type = $obj->get_schema->get_root_type
    }
    $obj = $obj->get_root;
  } elsif (exists $opts->{type}) {
    $type = $opts->{type};
  }
  __for_each_match_dispatch('','',\@match_paths,$obj,$type) if @match_paths;
}

sub __for_each_match_dispatch {
  my ($path, $step, $match_paths, $v, $type)=@_;
  $path .= $path eq '/' ? $step : '/'.$step;
  my $match = __match_path($match_paths,$step);
  my @m;
  if (defined $type) {
    my $dt = $type->get_decl_type;
    if ($dt==PML_ATTRIBUTE_DECL ||
        $dt==PML_MEMBER_DECL    ||
        $dt==PML_ELEMENT_DECL) {
      $type = $type->get_content_decl;
    }
  }
  for my $m (@$match) {
    if ( @{$m->[0]}>0 ) {
      push @m, $m;
    } else {
      my $cb = $m->[1];
      my @args;
      if (UNIVERSAL::isa($cb,'ARRAY')) {
        ($cb,@args) = @$cb;
      }
      $cb->({path => $path,  value => $v, type=>$type},@args);
    }
  }
  __for_each_match($path,$v,\@m,$type) if (@m);
}

sub __for_each_match {
  my ($p, $val, $match_paths,$type)=@_;
  if ($val) {
    my $dt = (defined($type)||undef) && $type->get_decl_type;
    if (defined($type) and $dt == PML_ALT_DECL and !UNIVERSAL::DOES::does($val, 'Treex::PML::Alt')) {
      $type=$type->get_content_decl;
      $dt=$type->get_decl_type;
    }
    if ((UNIVERSAL::DOES::does($val, 'Treex::PML::List') or UNIVERSAL::DOES::does($val, 'Treex::PML::Alt'))
        and (!defined($dt) ||
               $dt == PML_LIST_DECL ||
               $dt == PML_ALT_DECL)) {
      my $no = 1;
      my $content_type =(defined($type)||undef) && $type->get_content_decl;
      foreach my $v (@$val) {
        __for_each_match_dispatch($p,"[$no]",$match_paths,
                                  $v,$content_type);
        $no++;
      }
    } elsif ((UNIVERSAL::DOES::does($val, 'Treex::PML::Seq'))
               and (!defined($dt) || $dt == PML_SEQUENCE_DECL)) {
      my $no = 1;
      foreach my $e ($val->elements) {
        my $name = $e->name;
        my $content_type = (defined($type)||undef) && $type->get_element_by_name($name);
        if (!defined($type) || defined($content_type)) {
          __for_each_match_dispatch($p,"[$no]$name",$match_paths,
                                    $e->value, $content_type);
        }
        $no++;
      }
    } elsif (UNIVERSAL::isa($val,'HASH')
        and (!defined($dt)
               || $dt == PML_STRUCTURE_DECL
               || $dt == PML_CONTAINER_DECL)) {
      foreach my $name (keys %$val) {
        my $content_type = (defined($type)||undef) && $type->get_member_by_name($name);
        if (!defined($type) || defined($content_type)) {
          __for_each_match_dispatch($p,$name,$match_paths,$val->{$name},
                                    $content_type);
        }
      }
    }
  }
}
sub get_all_matches {
  my ($obj,$path_list,$opts) = @_;

  unless (UNIVERSAL::isa($path_list,"ARRAY")) {
    if (ref($path_list)) {
      die "Usage: ".__PACKAGE__."::get_all_matches: expected a string or a list, got $path_list";
    } else {
      $path_list = [$path_list];
    }
  }
  my @matches;
  my $sub = sub { push @matches, $_[0] };
  for_each_match($obj, { map { $_=>$sub } @$path_list }, $opts);
  return wantarray ? @matches : \@matches;
}
sub count_matches {
  my ($obj,$path_list,$opts) = @_;

  unless (UNIVERSAL::isa($path_list,"ARRAY")) {
    if (ref($path_list)) {
      die "Usage: ".__PACKAGE__."::get_all_matches: expected a string or a list, got $path_list";
    } else {
      $path_list = [$path_list];
    }
  }
  my $matches;
  my $sub = sub { $matches++ };
  for_each_match($obj, { map { $_=>$sub } @$path_list }, $opts);
  return $matches;
}


sub traverse_data {
  my ($value,$decl,$callback,$opts)=@_;
  $opts||={};
  die "Usage: traverse_data(\$data,\$type_decl,\$callback,\$option_hash)"
    unless blessed($value) and $decl->isa('Treex::PML::Schema::Decl')
      and ref($callback) eq 'CODE'
      and ref($opts) eq 'HASH';
  return _traverse_data($value,$decl,$callback,$opts);
}

sub _traverse_data {
  my ($value,$decl,$callback,$opts)=@_;
  my $decl_is = $decl->get_decl_type;
  my $desc;
  $callback->($value,$decl,$opts->{data});
  if ($decl_is == PML_STRUCTURE_DECL) {
    my @members = $decl->get_members;
    if ($opts->{no_childnodes}) {
      @members = grep {
        my $role = $_->get_role;
        !defined($role) or $role ne '#CHILDNODES'
      } $decl->get_members;
    }
    if ($opts->{no_trees}) {
      @members = grep {
        my $role = $_->get_role;
        !defined($role) or $role ne '#TREES'
      } $decl->get_members;
    }
    for (@members) {
      my $n = $_->get_knit_name;
      my $v = $value->{$n};
      _traverse_data($v,$_->get_knit_content_decl,$callback,$opts) if defined $v;
    }
  } elsif ($decl_is == PML_CONTAINER_DECL) {
    my @attrs = $decl->get_attributes;
    for (@attrs) {
      my $n = $_->get_name;
      my $v = $value->{$n};
      _traverse_data($v,$_->get_content_decl,$callback,$opts) if defined $v;
    }
    my $content_decl = $decl->get_knit_content_decl;
    my $v = $value->{'#content'};
    _traverse_data($v,$content_decl,$callback,$opts) if $v;
  } elsif ($decl_is == PML_SEQUENCE_DECL) {
    my @elems = $decl->get_elements;
    for (@{$value->elements_list}) {
      my $n = $_->name;
      my $v = $_->value;
      my $e = $decl->get_element_by_name($n);
      _traverse_data($v,$e,$callback,$opts) if $v and $e;
    }
  } elsif ($decl_is == PML_LIST_DECL || $decl_is == PML_ALT_DECL) {
    if ($decl_is == PML_ALT_DECL and not UNIVERSAL::DOES::does($value,'Treex::PML::Alt')) {
      $value=Treex::PML::Factory->createAlt([$value],1);
    }
    my $content_decl=$decl->get_knit_content_decl;
    for my $v ($value->values) {
      _traverse_data($v,$content_decl,$callback,$opts) if defined($v);
    }
  } elsif ($decl_is == PML_CHOICE_DECL || $decl_is == PML_CONSTANT_DECL || $decl_is == PML_CDATA_DECL) {
  } else {
    die "unhandled data type: $decl\n";
  }
  return;
}



##########################################
# Convert to Treex::PML::Document
#########################################

sub convert_to_fsfile {
  my ($ctxt,$fsfile,$opts)=@_;

  my $schema = $ctxt->{'_schema'};
  $opts||={};

  unless (ref($fsfile)) {
    $fsfile = Treex::PML::Factory->createDocument({ backend => 'PML' } );
  }

  $fsfile->changeURL( $ctxt->{'_filename'} );
  $fsfile->changeEncoding($DEFAULT_ENCODING);

  if ($schema->isa('Treex::PML::Schema') and not UNIVERSAL::DOES::does($schema, 'Treex::PML::Schema')) {
    # rebless
    require Treex::PML::Schema;
    bless $schema, 'Treex::PML::Schema';
  }
  $fsfile->changeMetaData( 'schema',         $schema                    );
  $fsfile->changeMetaData( 'schema-url',     $ctxt->{'_schema-url'}      );
  $fsfile->changeMetaData( 'schema-inline',  $ctxt->{'_schema-inline'}   );
  $fsfile->changeMetaData( 'pml_transform',  $ctxt->{'_transform_id'}    );
  $fsfile->changeMetaData( 'references',     $ctxt->{'_references'}      );
  $fsfile->changeMetaData( 'refnames',       $ctxt->{'_refnames'}        );
  $fsfile->changeMetaData( 'fs-require',
     [ map { [$_->{id},$_->{href}] }
         grep { $_->{readas} eq 'trees' } $ctxt->get_reffiles() ]
  );

  $fsfile->changeAppData(  'ref',            $ctxt->{'_ref'} || {}         );
#  $fsfile->changeAppData(  'ref-index',      $ctxt->{'_ref-index'} || {} );
  $fsfile->changeAppData(  'id-hash',        $ctxt->{'_id-hash'}         );

  $fsfile->changeMetaData( 'pml_root',       $ctxt->{'_root'}            );
  $fsfile->changeMetaData( 'pml_trees_type', $ctxt->{'_pml_trees_type'}  );
  $fsfile->changeMetaData( 'pml_prolog',     $ctxt->{'_pml_prolog'}        );
  $fsfile->changeMetaData( 'pml_epilog',     $ctxt->{'_pml_epilog'}        );

  if ($ctxt->{'_pi'}) {
    my @patterns = map { $_->[1] } grep { $_->[0] eq 'tred-pattern' } @{$ctxt->{'_pi'}};
    my ($hint) = map { $_->[1] } grep { $_->[0] eq 'tred-hint' } @{$ctxt->{'_pi'}} ;
    for (@patterns, $hint) {
      next unless defined;
      s/</
      s/>/>/g;
      s/&/&/g;
    }
    $fsfile->changePatterns( @patterns  );
    $fsfile->changeHint( $hint );
  }

  $fsfile->changeTrees( @{$ctxt->{'_trees'}} ) if $ctxt->{'_trees'};

  my @nodes = $ctxt->{'_schema'}->find_role('#NODE');
  my (@order,@hide);
  for my $path (@nodes) {
    my $node_decl = $schema->find_type_by_path($path);
    $node_decl or die "Type-path $path does not lead to anything\n";

    push @order, map { $_->get_name } $node_decl->find_members_by_role('#ORDER');
    push @hide, map { $_->get_name } $node_decl->find_members_by_role('#HIDE' );
  }
  my %uniq;
  @order = grep { !$uniq{$_} && ($uniq{$_}=1) } @order;
  %uniq=();
  @hide = grep { !$uniq{$_} && ($uniq{$_}=1) } @hide;
  if (@order>1) {
    _warn("Treex::PML::Document only supports #ORDER members/attributes with a same name: found {",
          join(',',@order),"}, using $order[0]!");
  }
  if (@hide>1) {
    _warn("Treex::PML::Document only supports #HIDE members/attributes with a same name: found {",
          join(',',@hide),"} $hide[0]!");
  }
  my $defs = $fsfile->FS->defs;
  $defs->{$order[0]} = ' N' if @order;
  $defs->{$hide[0]}  = ' H' if @hide;

  return $fsfile;
}

##########################################
# Convert from Treex::PML::Document
##########################################

sub convert_from_fsfile {
  my ($ctxt,$fsfile)=@_;

  unless (ref($ctxt)) {
    $ctxt = $ctxt->new();
  }

  $ctxt->{'_transform_id'}   = $fsfile->metaData('pml_transform');
  $ctxt->{'_filename'}       = $fsfile->filename;
  $ctxt->{'_schema'}         = $fsfile->metaData('schema');
  $ctxt->{'_root'}           = $fsfile->metaData('pml_root');
  $ctxt->{'_schema-inline'}  = $fsfile->metaData('schema-inline'); # not used anymore
  $ctxt->{'_schema-url'}     = $fsfile->metaData('schema-url');
  $ctxt->{'_references'}     = $fsfile->metaData('references');
  $ctxt->{'_refnames'}       = $fsfile->metaData('refnames');
  $ctxt->{'_pml_trees_type'} = $fsfile->metaData('pml_trees_type');
  $ctxt->{'_pml_prolog'}     = $fsfile->metaData('pml_prolog');
  $ctxt->{'_pml_epilog'}     = $fsfile->metaData('pml_epilog');
  $ctxt->{'_trees'}          = Treex::PML::Factory->createList( $fsfile->treeList );

  $ctxt->{'_refs_save'}      = $fsfile->appData('refs_save');

  $ctxt->{'_ref'}            = $fsfile->appData('ref');
#  $ctxt->{'_ref-index'}      = $fsfile->appData('ref-index');
  $ctxt->{'_id-hash'}        = $fsfile->appData('id-hash');

  my $PIs = $ctxt->{'_pi'} = [];
  for my $pattern ($fsfile->patterns) {
    $pattern =~ s/&/&/g;
    $pattern =~ s/
    $pattern =~ s/>/>/g;
    push @$PIs, ['tred-pattern', $pattern];
  }
  my $hint = $fsfile->hint;
  if (defined $hint and length $hint) {
    $hint =~ s/&/&/g;
    $hint =~ s/
    $hint =~ s/>/>/g;
    push @$PIs, [ 'tred-hint', $hint ];
  }

  return $ctxt;
}


1;
__END__