—

              
package Treex::PML::Instance::Reader;
{
use 5.008;
use strict;
use warnings;
no warnings qw(recursion);
use Scalar::Util qw(blessed);
use UNIVERSAL::DOES;
use Carp;
use Data::Dumper;
BEGIN {
  our $VERSION = '2.04'; # version template
}
use List::Util qw(first);
use Scalar::Util qw(weaken);
use Treex::PML::Instance::Common qw(:diagnostics :constants);
use Treex::PML::Schema;
use XML::LibXML::Reader;
use Treex::PML::IO qw(open_uri close_uri rename_uri);
use Encode;
use constant {
  XAT_TYPE  => 0,
  XAT_NAME  => 1,
  XAT_VALUE => 1,
  XAT_NS  => 2,
  XAT_ATTRS => 3,
  XAT_CHILDREN => 5,
  XAT_LINE => 4,
};
our $STRICT =1;
our $XTC_FLAGS;
use vars qw( $HAVE_XS );
BEGIN {
  if (!$ENV{PML_COMPILE_NO_XS} && eval {
    require XML::CompactTree::XS;
    import XML::CompactTree::XS;
    $HAVE_XS = 1;
    1;
  }) {
    # print STDERR "Using XML::CompactTree::XS\n" if $HAVE_XS;
    $XTC_FLAGS = XML::CompactTree::XS::XCT_ATTRIBUTE_ARRAY()|
                 XML::CompactTree::XS::XCT_LINE_NUMBERS()|
                 XML::CompactTree::XS::XCT_IGNORE_COMMENTS();
  } else {
    require XML::CompactTree;
    import XML::CompactTree;
    $XTC_FLAGS = XML::CompactTree::XCT_ATTRIBUTE_ARRAY()|
                 XML::CompactTree::XCT_LINE_NUMBERS()|
                 XML::CompactTree::XCT_IGNORE_COMMENTS();
    $HAVE_XS = 0;
  }
}
my (%handlers,%src,
    %handler_cache,@handler_cache,
    %schema_cache,@schema_cache
   );
# TODO:
# - create one handler per cdata+format type
# - test inline schemas
our $CACHE_HANDLERS=1;
our $CACHE_SCHEMAS=1;
our $MAX_SCHEMA_CACHE_SIZE=50;
our $VALIDATE_CDATA=0;
our $VALIDATE_SEQUENCES=1;
our $BUILD_TREES = 1;
our $LOAD_REFFILES = 1;
our $KNIT = 1;
our $READER_OPTS = {
  no_cdata => 1,
  clean_namespaces => 1,
  expand_entities => 1,
  expand_xinclude => 1,
  no_xinclude_nodes => 1,
};
require Treex::PML;
sub _get_handlers_cache_key {
  my ($schema)=@_;
  my $key="$schema"; $key=~s/.*=//; # strip class
  return
    [
      $key,
      join ',',
      $key,
      $VALIDATE_CDATA || 0,
      $VALIDATE_SEQUENCES || 0,
      $BUILD_TREES || 0,
      $LOAD_REFFILES || 0,
      $KNIT || 0,
      $Treex::PML::Node::TYPE,
      $Treex::PML::Node::lbrother,
      $Treex::PML::Node::rbrother,
      $Treex::PML::Node::parent,
      $Treex::PML::Node::firstson,
     ];
}
sub _get_schema_cache_key {
  my ($schema_file)=@_;
  if ((blessed($schema_file) and $schema_file->isa('URI'))) { # assume URI
    if (($schema_file->scheme||'') eq 'file') {
      $schema_file = $schema_file->file
    } else {
      return '0 '.$schema_file;
    }
  }
  if (-f $schema_file) {
    my $mtime = (stat $schema_file)[9];
    return $mtime.' '.$schema_file;
  }
}
sub get_cached_schema {
  my ($schema_file)=@_;
  return unless defined $schema_file;
  my $cached = $schema_cache{$schema_file};
  if ($cached and $schema_cache[-1] ne $schema_file) {
    # move the last retrieved schema to the end of the queue
    @schema_cache = ((grep { $_ ne $schema_file } @schema_cache),$schema_file);
  }
  return $cached;
}
sub cache_schema {
  my ($key,$schema)=@_;
  push @schema_cache,$key;
  $schema_cache{$key} = $schema;
  if (@schema_cache > $MAX_SCHEMA_CACHE_SIZE) {
    my $del = delete $schema_cache{ shift @schema_cache };
    delete $handler_cache{ $del }; # delete also from the handler cache
    @handler_cache = grep { $_->[0] ne $del } @handler_cache;
    if (exists &Treex::PML::Instance::Writer::forget_schema) {
      Treex::PML::Instance::Writer::forget_schema($schema);
    }
  }
}
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 load {
  my $ctxt = shift;
  my $opts = shift;
  if (ref($opts) ne 'HASH') {
    croak("Usage: Treex::PML::Instance->load({option=>value,...})\n");
  }
  if (!ref($ctxt)) {
    $ctxt = Treex::PML::Factory->createPMLInstance;
  }
  my $config = $opts->{config};
  if ($config and ref(my $load_opts = $config->get_data('options/load'))) {
    $opts = {%$load_opts, %$opts};
  }
  $Treex::PML::Instance::DEBUG = $config->get_data('options/debug') if (!$Treex::PML::Instance::DEBUG and $config and defined($config->get_data('options/debug')));
  local $READER_OPTS = { %$READER_OPTS, %{$opts->{parser_options} || {}} };
  if (exists $opts->{filename}) {
    $ctxt->set_filename( $opts->{use_resources}
                           ? Treex::PML::FindInResourcePaths($opts->{filename})
                           : $opts->{filename}
                       );
  }
  my $reader;
  my $fh_to_close;
  # print Dumper($opts),"\n";
  if (defined $opts->{dom}) {
    $reader = XML::LibXML::Reader->new(DOM => delete $opts->{dom}, %$READER_OPTS);
  } elsif (defined $opts->{fh}) {
    $reader = XML::LibXML::Reader->new(IO => $opts->{fh}, %$READER_OPTS,
                                       URI => $ctxt->{'_filename'},
                                       %$READER_OPTS
                                      );
  } elsif (defined $opts->{string}) {
    $reader = XML::LibXML::Reader->new(string => $opts->{string}, %$READER_OPTS,
                                       URI => $ctxt->{'_filename'},
                                       %$READER_OPTS
                                      );
  } elsif (defined $ctxt->{_filename}) {
    if ($ctxt->{_filename} eq '-') {
      $reader = XML::LibXML::Reader->new(FD => \*STDIN,
                                         %$READER_OPTS,
                                        );
    } else {
      $fh_to_close = open_uri($ctxt->{_filename});
      $reader = XML::LibXML::Reader->new(FD => $fh_to_close,
                                         URI => $ctxt->{_filename},
                                         %$READER_OPTS,
                                        );
    }
  } else {
    croak("Treex::PML::Instance->load: at least one of filename, fh, string, or dom arguments are required!");
  }
  eval {
  # check NS
  $reader->nextElement();
  my @transform_map =
    grep {
      my $id = $_->{id};
      if (defined($id) and length($id)) {
        $_
      } else {
        warn(__PACKAGE__.": Skipping PML transform in ".$config->get_url." (required attribute id missing):".Dumper($_));
        ()
      }
    }
    (eval {
      ($config and $config->get_root) ? $config->get_root->{transform_map}->values : ()
    });
  my $root_element = $reader->localName;
  my $root_ns = $reader->namespaceURI || '';
  if ($root_ns ne PML_NS
        or grep { (($_->{ns}||'') eq PML_NS and ($_->{root}||'') eq $root_element) } @transform_map) {
    if ($config and $config->get_root and eval { require XML::LibXSLT; 1 }) {
      # TRANSFORM
      $reader->preserveNode;
      $reader->finish;
      my $dom = $reader->document;
      foreach my $transform (@transform_map) {
        my $id = $transform->{'id'};
        my ($in_xsl) = $transform->{in};
        my $type = $in_xsl && $in_xsl->{'type'};
        next unless ($type and $type =~ /^(?:xslt|perl|pipe|shell)$/);
        my $test = $transform->{'test'};
        _debug("Trying transformation rule '$id'");
        if (($test or $transform->{ns} or $transform->{root})
            and (!$transform->{ns} or $transform->{ns} eq $root_ns)
            and (!$transform->{root} or $transform->{root} eq $root_element)
            and !$test or eval { $dom->find($test) }) {
          if ($type eq 'xslt') {
            my $in_xsl_href = URI->new(Encode::encode_utf8($in_xsl->get_member('href')));
            next unless $in_xsl_href;
            _debug("Transforming to PML with XSLT '$in_xsl_href'");
            $ctxt->{'_transform_id'} = $id;
            my $params = $in_xsl->content;
            my %params;
            %params = map { $_->{'name'} => $_->value } $params->values if $params;
            $in_xsl_href = Treex::PML::ResolvePath($config->{'_filename'}, $in_xsl_href, 1);
            my $xslt = XML::LibXSLT->new;
            my $in_xsl_parsed = $xslt->parse_stylesheet_file($in_xsl_href)
              || die("Cannot locate XSL stylesheet '$in_xsl_href' for transformation $id\n");
            $dom = $in_xsl_parsed->transform($dom,%params);
            $dom->setBaseURI($ctxt->{'_filename'}) if $dom and $dom->can('setBaseURI');
            $dom->setURI($ctxt->{'_filename'}) if $dom and $dom->can('setURI');
            $reader = XML::LibXML::Reader->new(DOM => $dom);
            $reader->nextElement();
            last;
          } elsif ($type eq 'perl') {
            my $code = $in_xsl->get_member('command');
            next unless $code;
            _debug("Transforming to PML with Perl code: $code");
            $ctxt->{'_transform_id'} = $id;
            my $params = $in_xsl->content;
            my %params;
            %params = map { $_->{'name'} => $_->value } $params->values if $params;
            $dom = perl_transform($code, $dom, %params);
            die("Perl-based transformation '$id' failed: $@") if $@;
            die("Perl-based transformation didn't return a XML::LibXML::Document object!\n") unless
              (blessed($dom) and $dom->isa('XML::LibXML::Document'));
            $dom->setBaseURI($ctxt->{'_filename'}) if $dom and $dom->can('setBaseURI');
            $dom->setURI($ctxt->{'_filename'}) if $dom and $dom->can('setURI');
            $reader = XML::LibXML::Reader->new(DOM => $dom);
            $reader->nextElement();
            last;
          } elsif ($type eq 'pipe' or $type eq 'shell') {
            my $code = $in_xsl->get_member('command');
            next unless $code;
            _debug("Transforming to PML with $type code: $code");
            $ctxt->{'_transform_id'} = $id;
            my $params = $in_xsl->content;
            my @params;
            @params = grep {defined and length } map { $_->{'name'} => $_->value } $params->values if $params;
            my $tmp_file_in;
            if ($type eq 'pipe') {
              (my $fh, $tmp_file_in) = File::Temp::tempfile();
              $dom->toFH($fh);
              close $fh;
            } else {
              push @params, $dom->URI;
            }
            my $tmp_file_out;
            {
              local *OLDIN;
              local *OLDOUT;
              open OLDOUT,"<&STDOUT";
              open OLDIN,"<&STDIN";
              if ($type eq 'pipe') {
                open STDIN, '<', $tmp_file_in;
              } else {
                close STDIN;
              }
              (undef, $tmp_file_out) = File::Temp::tempfile();
              open STDOUT, '>', $tmp_file_out;
              system($code,@params);
              unlink $tmp_file_in if $tmp_file_in;
              open STDIN,"<&OLDIN";
              open STDOUT,">&OLDOUT";
            }
            {
              open(my $fh, '<', $tmp_file_out) or die("Failed to read output from pipe transformation: $code\n");
              unlink $tmp_file_out if $tmp_file_out;
              $reader = XML::LibXML::Reader->new(IO => $fh, URI => $ctxt->{'_filename'});
            }
            $reader->nextElement();
            last;
          }
        } else {
          _debug("failed");
        }
      }
    }
    if (($reader->namespaceURI||'') ne PML_NS) {
      my $f = $ctxt->{'_filename'} || '';
      die("Root element of '$f' isn't in PML namespace: '".($reader->localName()||'')."' ".($reader->namespaceURI()||''))
    }
  }
  $ctxt->{_root} = read_header($ctxt,$reader,$opts);
  my $schema = $ctxt->{'_schema'};
  unless (ref($schema)) {
    die("Instance doesn't provide PML schema!");
  }
  unless (length($schema->{version}||'')) {
    die("PML Schema file ".$ctxt->{'_schema-url'}." does not specify version!");
  }
  if (index(SUPPORTED_PML_VERSIONS," ".$schema->{version}." ")<0) {
    die("Unsupported PML Schema version ".$schema->{version}." in ".$ctxt->{'_schema-url'});
  }
  {
    # preprocess the options selected_references and selected_keys:
    # we map the reffile names to reffile id's
    my $sel_knit = ($ctxt->{_selected_knits} =
                      $opts->{selected_knits});
    my $sel_refs = ($ctxt->{_selected_references} =
                      $opts->{selected_references});
    croak("Treex::PML::Instance->load: selected_knits must be a Hash ref!")
      if defined($sel_knit) && ref($sel_knit) ne 'HASH';
    croak("Treex::PML::Instance->load: selected_references must be a Hash ref!")
      if defined($sel_refs) && ref($sel_refs) ne 'HASH';
    ($ctxt->{'_selected_knits_ids'},
     $ctxt->{'_selected_references_ids'}) = map {
       my $sel = $_;
       my $ret = {
         (defined($sel) ?
           (map {
             my $ids = $ctxt->{'_refnames'}->{$_};
             my $val = $sel->{$_};
             map { $_=>$val } 
               defined($ids) ? (ref($ids) ? @$ids : ($ids)) : ()
           } keys %$sel) : ())
        };
       $ret
     } ($sel_knit,$sel_refs);
  }
  $ctxt->read_reffiles({use_resources=>$opts->{use_resources}});
  $ctxt->{'_no_read_trees'} = $opts->{no_trees};
  local $BUILD_TREES = $opts->{no_trees} ? 0 : 1;
  local $LOAD_REFFILES = $opts->{no_references} ? 0 : 1;
  local $KNIT = $opts->{no_knit} ? 0 : $LOAD_REFFILES;
  local $VALIDATE_CDATA =$opts->{validate_cdata} ? 1 : 0;
  local $VALIDATE_SEQUENCES =$opts->{ignore_content_patterns} ? 0 : 1;
  $ctxt->{'_id-hash'}={};
  prepare_handlers($ctxt);
  dump_handlers($ctxt) if $opts->{dump_handlers} or $ENV{PML_COMPILE_DUMP};
  load_data($ctxt,$reader,$opts);
  while ($reader->read) {
    if ($reader->nodeType == XML_READER_TYPE_PROCESSING_INSTRUCTION) {
      push @{$ctxt->{'_pi'}}, [ $reader->name,$reader->value ];
    }
  }
  $handlers{'#initialize'}->($ctxt);
  $ctxt->{_root} = $handlers{'#root'}->($ctxt->{_root});
  };
  ($handlers{'#cleanup'}||sub{})->();
  %handlers=();
  close_uri($fh_to_close) if defined $fh_to_close;
  die $@ if $@;
  $ctxt->{'_parser'} = undef;
  return $ctxt;
}
######################################################
# $ctxt
sub _reader_address {
  my ($ctxt,$reader)=@_;
  my $line_number=$reader->lineNumber;
  return " at ".$ctxt->{'_filename'}." line ".$line_number."\n";
}
sub read_header {
  my ($ctxt,$reader,$opts)=@_;
  # manually extract the root node
  my $root = [XML_READER_TYPE_ELEMENT,
              $reader->localName,
              undef,
             ];
  # read root node attributes
  $root->[XAT_LINE] = 0;
  $root->[XAT_ATTRS] = readAttributes($reader);
  my $found_head = 0;
  while ($reader->read == 1) {
    my $type = $reader->nodeType;
    if ($type == XML_READER_TYPE_TEXT) { # no CDATA
      die "Unexpected content of a root element preceding <head>"._reader_address($ctxt,$reader);
    } elsif ($type == XML_READER_TYPE_ELEMENT) {
      if ($reader->localName eq 'head' and $reader->namespaceURI eq PML_NS) {
        # we have head!
        $found_head = 1;
        last;
      } else {
        die "Unexpected element '".$reader->name."' precedes PML header <head>"._reader_address($ctxt,$reader);
      }
    }
  }
  unless ($found_head) {
    die "Did not find PML <head> element: the document '".$ctxt->{_filename}."' is not a PML instance!";
  }
  my (%references,%named_references);
  while ($reader->read == 1) {
    last if $reader->depth<=1;
    my $type = $reader->nodeType;
    if ($type == XML_READER_TYPE_ELEMENT and $reader->namespaceURI eq PML_NS) {
      my $name = $reader->localName;
      if ($name eq 'schema') {
        if ($ctxt->{'_schema'}) {
          warn "Multiple <schema> elements in a PML <head>!";
          $reader->nextSibling || last;
          redo;
        }
        # read schema here:
        my %a = @{ readAttributes($reader) || [] };
        my $schema_file = delete $a{href};
        if (defined $schema_file and length $schema_file) {
          $schema_file = URI->new(Encode::encode_utf8($schema_file));
          # print "$schema_file\n";
          $ctxt->{'_schema-url'} = $schema_file; # store the original URL, not the resolved one!
          my $schema_path = Treex::PML::ResolvePath($ctxt->{'_filename'},$schema_file,1);
          my $key = _get_schema_cache_key($schema_path);
          if (!($ctxt->{'_schema'}=get_cached_schema($key))) {
            # print "loading schema $schema_path\n";
            $ctxt->{'_schema'} =
              Treex::PML::Factory->createPMLSchema({
                filename => $schema_path,
                use_resources => 1,
                revision_error => 
                  "Error: ".$ctxt->{'_filename'}." requires different revision of PML schema %f: %e\n",
                %a, # revision_opts
              });
            cache_schema($key, $ctxt->{'_schema'}) if $CACHE_SCHEMAS;
          }
        } else {
          # inline schema
          $ctxt->{'_schema'} = Treex::PML::Factory->createPMLSchema({
            reader=>$reader,
            base_url => $ctxt->{'_filename'},
            use_resources => 1,
            revision_error => 
              "Error: ".($ctxt->{'_filename'}||'document')." requires different revision of PML schema %f: %e\n",
            %a, # revision_opts
          });
        }
      } elsif ($name eq 'references') {
        if ($reader->read) {
          while ($reader->depth==3) {
            if ($reader->localName eq 'reffile' and
                  $reader->namespaceURI eq PML_NS) {
              my %a = @{ readAttributes($reader) || [] };
              my ($id,$name,$href) = @a{qw(id name href)};
              if (defined($id) and length($id) and
                    defined($href) and length($href)) {
                if (defined $name and length $name) {
                  my $prev_ids = $named_references{ $name };
                  if (defined $prev_ids) {
                    if (ref($prev_ids)) {
                      push @$prev_ids,$id;
                    } else {
                      $named_references{ $name }=Treex::PML::Factory->createAlt([$prev_ids,$id],1);
                    }
                  } else {
                    $named_references{ $name } = $id;
                  }
                }
                # Encode: all filenames must(!) be bytes
                $references{$id} = Treex::PML::ResolvePath
                  ($ctxt->{'_filename'},
                   URI->new(Encode::encode_utf8($href)),
                   $opts->{use_resources});
                # Resources are not used for non-readas references,
                # though, they must be handled manually.
              } else {
                warn "Missing id or href attribute on a <reffile>: ignoring\n";
              }
            }
            $reader->nextSibling || last;
          }
        }
      }
    }
  }
  $ctxt->{'_schema'} or 
    die "Did not find <schema> element in PML <head>: the document '".$ctxt->{_filename}."' is not a valid PML instance!";
  $ctxt->{'_references'} = \%references;
  $ctxt->{'_refnames'} = \%named_references;
  return $root;
}
sub prepare_handlers {
  my ($ctxt,$opts)=@_;
  %handlers=();
  my $schema = $ctxt->{'_schema'};
  my $key=_get_handlers_cache_key($schema);
  my $cached = get_cached_handlers($key);
  if ($cached) {
    %handlers= @$cached;
  } else {
    compile_schema($schema);
    cache_handlers($key,[%handlers]) if $CACHE_HANDLERS;
  }
}
sub dump_handlers {
  my $dir = '.pml_compile.d';
  (-d $dir) || mkdir($dir) || die "Can't dump to $dir: $!\n";
  # print "created $dir\n";
  for my $f (keys %src) {
    my $dump_file = File::Spec->catfile($dir,$f);
    open (my $fh, '>:utf8', $dump_file)
      || die "Can't write to $dump_file: $!\n";
    my $sub = $src{$f};
    $sub=~s/^\s*#line[^\n]*\n//;
    print $fh ($sub);
    close $fh;
  }
}
sub load_data {
  my ($ctxt,$reader)=@_;
  my $root = $ctxt->{_root};
  my ($children);
  $reader->read if $reader->nodeType == XML_READER_TYPE_END_ELEMENT;
  if ($HAVE_XS) {
    my %ns;
    $children = XML::CompactTree::XS::readLevelToPerl(
      $reader,
      $XTC_FLAGS,
      \%ns
     );
    $root->[XAT_NS]=$ns{(PML_NS)} || -1;
  } else {
    my %ns;
    $children = XML::CompactTree::readLevelToPerl(
      $reader,
      $XTC_FLAGS,
      \%ns
     );
    $root->[XAT_NS]=$ns{(PML_NS)} || -1;
  }
  $root->[XAT_CHILDREN]=$children;
  # print Dumper($root);
#   print Dumper({references => $ctxt->{'_references'},
#               refnames => $ctxt->{'_refnames'}});
  return $root;
}
sub _set_trees_seq {
  my ($ctxt,$type,$data)=@_;
  $ctxt->{'_pml_trees_type'} = $type;
  my $trees  = $ctxt->{'_trees'} ||= Treex::PML::Factory->createList;
  my $prolog = $ctxt->{'_pml_prolog'} ||= Treex::PML::Factory->createSeq;
  my $epilog = $ctxt->{'_pml_epilog'} ||= Treex::PML::Factory->createSeq;
  my $phase = 0; # prolog
  foreach my $element (@$data) {
    my $val = $element->[1];
    if (UNIVERSAL::DOES::does($val,'Treex::PML::Node')) {
      if ($phase == 0) {
        $phase = 1;
      }
      if ($phase == 1) {
        $val->{'#name'} = $element->[0]; # manually delegate_name on this element
        push @$trees, $val;
      } else {
        $prolog->push_element_obj($element);
      }
    } else {
      if ($phase == 1) {
        $phase = 2; # start epilog
      }
      if ($phase == 0) {
        $prolog->push_element_obj($element);
      } else {
        $epilog->push_element_obj($element);
      }
    }
  }
}
sub readAttributes {
  my ($r)=@_;
  my @attrs;
  my ($prefix,$name);
  if ($r->moveToFirstAttribute==1) {
    do {{
      $prefix = $r->prefix;
      $name = $r->localName;
      push @attrs, ($name,$r->value) unless ($prefix and $prefix eq 'xmlns') or (!$prefix and $name eq 'xmlns');
    }} while ($r->moveToNextAttribute==1);
    $r->moveToElement;
  }
  \@attrs;
}
sub _paste_last_code {
  my ($node,$prev,$p)=@_;
  return qq`
            #$node\->{'$Treex::PML::Node::rbrother'}=undef;
            $prev\->{'$Treex::PML::Node::rbrother'}=$node;
            weaken( $node\->{'$Treex::PML::Node::lbrother'} = $prev );
            weaken( $node\->{'$Treex::PML::Node::parent'} = $p );
`;
}
sub _paste_first_code {
  my ($node,$p)=@_;
  return qq`
           #$node\->{'$Treex::PML::Node::rbrother'}=undef;
           #$node\->{'$Treex::PML::Node::lbrother'}=undef;
           $p\->{'$Treex::PML::Node::firstson'}=$node;
           weaken( $node\->{'$Treex::PML::Node::parent'} = $p );
`;
}
sub hash_id_code {
  my ($key,$value)=@_;
  return q`
        for (`.$key.q`) {
          if (defined and length) {
            if (exists($ID_HASH->{$ID_PREFIX.$_}) and
                $ID_HASH->{$ID_PREFIX.$_} != `.$value.q`) {
               warn("Duplicated ID '$_'");
            }
            weaken( $ID_HASH->{$ID_PREFIX.$_} = `.$value.q` );
          }
        }`
}
sub _fix_id_member {
  my ($decl)=@_;
  return unless $decl;
  my ($idM) = $decl->find_members_by_role('#ID');
  if ($idM) {
    # what follows is a hack fixing buggy PDT 2.0 schemas
    my $cdecl = $idM->get_content_decl(1); # no_resolve
    if ($cdecl and $cdecl->get_decl_type == PML_CDATA_DECL and $cdecl->get_format eq 'ID') {
      $cdecl->set_format('PMLREF');
    } elsif ($cdecl = $idM->get_content_decl()) {
      if ($cdecl and $cdecl->get_decl_type == PML_CDATA_DECL and $cdecl->get_format eq 'ID') {
          warn "Trying to knit object of type '".$decl->get_decl_path."' which has an #ID-attribute ".
            "'".$idM->get_name."' declared as <cdata format=\"ID\"/>. ".
              "Note that the data-type for #ID-attributes in objects knitted as DOM should be ".
                "<cdata format=\"PML\"/> (Hint: redeclare with <derive> for imported types).";
      }
    }
  }
  return $idM;
}
sub knit_code {
  my ($decl,$assign,$fail)=@_;
  my $sub = q`
             if ($ref) {
               $ref =~ s/^(?:(.*?)\#)//;
               my $file_id = $1||'';
               my $do_knit=$selected_knits->{$file_id};
               unless (defined($do_knit) and $do_knit==0) {
                 my $target;
                 if (length $file_id) {
                   my $f = $parsed_reffile->{ $file_id };
                   if (ref $f) {
                     if (UNIVERSAL::DOES::does($f,'Treex::PML::Instance')) {
                       $target = $f->{'_id-hash'}->{$ref};
                       $target->{'#knit_prefix'}=$file_id;
                     } else { # DOM`;
  if ($decl) {
    my $idM = _fix_id_member($decl);
    my $idM_name = $idM && $idM->get_name;
    my $decl_path = $decl->get_decl_path; $decl_path =~ s/^!//;
    $sub .= q`
                       my $dom_node = $ref_index->{$file_id}{$ref} || $f->getElementsById($ref);
                       if (defined $dom_node) {
                         $target  = $ID_HASH->{$ID_PREFIX.$file_id.'#'.$ref};
                         if (!defined $target) {
                            my $p = $ID_PREFIX;
                            $ID_PREFIX.=$file_id.'#';
                            my $r = XML::LibXML::Reader->new(string=>'<f xmlns="`.PML_NS.q`">'.$dom_node->toString.'</f>');
                            $r->nextElement;
                            # print $r, $dom_node->toString,"\n";
                            my %ns;
                            my $tree = XML::CompactTree`.($HAVE_XS ? '::XS' : '').q`::readSubtreeToPerl($r,`.$XTC_FLAGS.q`,\%ns);
                            my $index = $pml_ns_index;
                            $pml_ns_index = $ns{'`.PML_NS.q`'} || -1;
                            # print "index: $pml_ns_index\n";
                            # print Dumper($tree->[0][XAT_CHILDREN][0]);
                            $target = $handlers{'`.$decl_path.q`'}->($tree->[XAT_CHILDREN][0]);`;
    if ($idM) {
      $sub .= q`
                            $target->{`.$idM_name.q`}=$file_id.'#'.$target->{`.$idM_name.q`} if $target;`;
    }
    $sub .= q`
                            $pml_ns_index = $index;
                            $weaken=0;
                            $ID_PREFIX=$p;
                         }
                        }`;
  } else {
    $sub .= q`
                        warn("DOM knit error: knit content type not declared in the schema!\n");`;
  }
  $sub.=q`
                     }
                   } else {
                     warn("warning: KNIT failed: document '$file_id' not loaded\n");
                   }
                 } else {
                   $target = $ID_HASH->{$ID_PREFIX.$ref};
                 }
                 if (ref $target) {`.$assign.q`
                 } else {
                   warn("warning: KNIT failed: ID $ref not found in reffile '$file_id'\n");`.$fail.q`
                 }
               }
             }
          `;
  return $sub;
}
sub _report_error {
  my ($err)=@_;
  if ($STRICT) {die $err} else {warn $err};
}
sub _unhandled {
  my ($what,$pml_file,$el,$path)=@_;
  _report_error( "Error: $what not declared for type '$path' at ".$pml_file." line ".$el->[XAT_LINE] );
  return sub{};
}
sub compile_schema {
  my ($schema)=@_;
  my $schema_name = $schema->get_root_decl->get_name;
  my ($ctxt,$pml_file,$pml_ns_index,$ID_HASH,$ID_PREFIX,$selected_knits,$ref_index,$parsed_reffile,$trees_type,$have_trees);
  $handlers{'#cleanup'}= sub {
    undef $_ for ($ctxt,$pml_file,$pml_ns_index,$ID_HASH,$ID_PREFIX,$selected_knits,$ref_index,$parsed_reffile);
  };
  $handlers{'#initialize'}= sub {
    my ($instance)=@_;
    $ctxt = $instance;
    $pml_file = $instance->{'_filename'};
    $pml_ns_index = $instance->{_root}->[XAT_NS];
    $selected_knits = $instance->{_selected_knits_ids};
    $ref_index = $instance->{'_ref-index'};
    $ID_HASH = $instance->{'_id-hash'};
    $ID_PREFIX = $instance->{'_id_prefix'} || '';
    $parsed_reffile=$instance->{'_ref'};
    $have_trees = 0;
  };
  $schema->for_each_decl(sub {
    my ($decl)=@_;
    #  no warnings 'uninitialized';
    my $decl_type=$decl->get_decl_type;
    my $path = $decl->get_decl_path;
    $path =~ s/^!// if $path;
    return if $decl_type == PML_ATTRIBUTE_DECL ||
      $decl_type == PML_MEMBER_DECL    ||
        $decl_type == PML_TYPE_DECL      ||
          $decl_type == PML_ELEMENT_DECL;
    if ($decl_type == PML_ROOT_DECL) {
      my $name = $decl->get_name;
      my $cpath = $decl->get_content_decl->get_decl_path;
      $cpath =~ s/^!//;
      my $src = $schema_name.'__generated_read_root';
      my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
    sub {
      my ($p)=@_;
      unless (ref($p) and
              $p->[XAT_TYPE] == XML_READER_TYPE_ELEMENT and
              $p->[XAT_NS] == $pml_ns_index and
              $p->[XAT_NAME] eq '`.$name.q`'
             ) {
        die q(Did not find expected root element '`.$name.q` in ').$pml_file;
      }
      return ($handlers{ '`.$cpath.q`' })->($p);
    }`;
      $src{$src}=$sub;
      $handlers{'#root'}=eval $sub; die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_STRUCTURE_DECL) {
      #    print $path,"\n";
      my $src = $schema_name.'__generated_read_structure@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
       sub {
         my ($p)=@_;
         my $a=$p->[XAT_ATTRS];
         my $c=$p->[XAT_CHILDREN];
         # print join(",",map {defined($_) ? $_ : 'undef'} $p->[XAT_NAME],$p->[XAT_LINE],@$p)."\n";
         my (%s,$k,$v);`;
      if ($VALIDATE_CDATA) {
        $sub .= q`
         if ($a) {
           while (@$a) {
             $k=shift @$a;
             $v=shift @$a;
             $s{ $k } = ($handlers{ '`.$path.q`/'.$k }||_unhandled("attribute member '$k'",$pml_file,$p,'`.$path.q`'))->( $v );
           }
         }`;
      } else {
        $sub .= q`
         %s = @$a if $a;`;
      }
      $sub .= q`
         if ($c) {
           for my $el (@$c) {
             unless (ref($el) and $el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT
                     and $el->[XAT_NS] == $pml_ns_index) {
               if (!ref($el) || $el->[XAT_TYPE] == XML_READER_TYPE_TEXT || $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
                 warn q(Ignoring unexpected text content ').$el->[XAT_VALUE].q('  in a structure '`.$path.q`');
               } elsif ($el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT) {
                 warn q(Ignoring unexpected element ').$el->[XAT_NAME].q(' in a structure '`.$path.q`');
               }
               next;
             }
             $k = $el->[XAT_NAME];
             $s{ $k } = ($handlers{ '`.$path.q`/'.$k }||_unhandled("member '$k'",$pml_file,$el,'`.$path.q`'))->($el);
           }
         }`;
      my ($id, $children_member);
      for my $member ($decl->get_members) {
        my $mdecl = $member->get_content_decl;
        if ($member->is_required) {
          my $name = $member->get_name;
          if ($mdecl && $mdecl->get_role eq '#TREES') {
            # this is a bit of a hack:
            # in this case, if the trees have been read from the member, the member handler returns
            # a stub value '#TREES' that will get deleted
            $sub.=q`
            ref or ($_ eq '#TREES' and delete($s{'`.$name.q`'})) or warn q(Missing required member '`.$name.q`' in structure '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE] for $s{'`.$name.q`'};`;
          } else {
            $sub.=q`
         ref or defined and length or warn q(Missing required member '`.$name.q`' in structure '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE] for $s{'`.$name.q`'};`;
          }
        } elsif ($mdecl and $mdecl->get_decl_type == PML_CONSTANT_DECL) {
          $sub.=q`
         defined or $_="`.quotemeta($mdecl->{value}).q`" for $s{'`.$member->get_name.q`'};`;
        }
        my $role = $member->get_role;
        if ($KNIT and !$role) {
          $mdecl ||= $member->get_content_decl;
          if ($mdecl and $mdecl->get_decl_type == PML_LIST_DECL and
              $mdecl->get_role eq '#KNIT') {
            my $mname = $member->get_name;
            my $knit_name = $mname; $knit_name=~s/\.rf$//;
#           warn("#KNIT on list not yet implemented: ".$member->get_name."\n");
            $sub .=q`
          my $ref_list = $s{'`.$mname.q`'};
          if ($ref_list) {
            my (@knit_list,@weaken,$weaken);
             for my $ref (@$ref_list) {
               $weaken=1;`
            .knit_code($mdecl->get_knit_content_decl(),q`
                   push @knit_list, $target;
                   push @weaken, $weaken;`,
                  q`undef $ref_list; last;`)
            .q`
            }
            if (defined $ref_list) {
              my $i=0;
              for (@knit_list) {
                weaken($_) if $weaken[$i++];
              }
              $s{'`.$knit_name.q`'}=Treex::PML::Factory->createList(\@knit_list);`;
            if ($mname ne $knit_name) {
              $sub .= q`delete $s{'`.$mname.q`'};`;
            }
            $sub .= q`
            } else {
              warn("KNIT failed on list '`.$mname.q`'");
            }
          }`;
          next;
          }
        }
        if ($role eq '#ID') {
          $id = $member->get_name;
        } elsif (!$trees_type and $role eq '#TREES' and $BUILD_TREES) {
          $mdecl ||= $member->get_content_decl;
          my $mtype = $mdecl->get_decl_type;
          if ($mtype == PML_LIST_DECL) {
            # check that content type is of role #NODE
            my $cmdecl = $mdecl->get_content_decl;
            my $cmdecl_type = $cmdecl->get_decl_type;
            unless ($cmdecl && ($cmdecl->get_role||'') eq '#NODE' &&
                      ($cmdecl_type == PML_STRUCTURE_DECL or
                         $cmdecl_type == PML_CONTAINER_DECL)) {
              _report_error("List '$path' with role #TREES may only contain structures or containers with role #NODE in schema ".
                $decl->get_schema->get_url."\n");
            }
            $trees_type = $mdecl;
            $sub .= q`
          unless ($have_trees) {
            $ctxt->{'_pml_trees_type'} = $trees_type;
            $have_trees=1;
            $ctxt->{'_trees'} = delete $s{'`.$member->get_name.q`'};
          }`;
          } elsif ($mtype == PML_SEQUENCE_DECL) {
            $trees_type = $mdecl;
            $sub .= q`
             unless ($have_trees) {
               $have_trees=1;
               defined($_) && _set_trees_seq($ctxt,$trees_type,$_->elements_list) for (delete $s{'`.$member->get_name.q`'});
             }`;
          } else {
            _report_error("#TREES member '$path/".$member->get_name."' is neither a list nor a sequence in schema ".$member->get_schema->get_url."\n");
          }
        } elsif ($role eq '#CHILDNODES') {
          if ($children_member) {
            _report_error("#CHILDNODES role defined on multiple members of type '$path': '$children_member' and '".$member->get_name."' in schema ".$member->get_schema->get_url."\n");
          } else {
            $children_member=$member->get_name;
          }
        } elsif ($role eq '#KNIT' and $KNIT) {
          my $mname = $member->get_name;
          my $knit_name = $mname; $knit_name=~s/\.rf$//;
          $sub .= q`
            my $ref = $s{'`.$mname.q`'}; my $weaken = 1;`
          .knit_code($member->get_knit_content_decl,q`
                   if ($weaken) {
                     weaken( $s{'`.$knit_name.q`'}=$target );
                   } else {
                     $s{'`.$knit_name.q`'}=$target;
                   } `.
                   ($mname ne $knit_name ? q`delete $s{'`.$mname.q`'};` : ''), '');
        }
      }
      if ($decl->get_role eq '#NODE' and $BUILD_TREES) {
        $sub .= q`
         my $node = Treex::PML::Factory->createTypedNode($decl,\%s,1);
         # my $node = bless \%s, 'Treex::PML::Node';
         # $node->{`.$Treex::PML::Node::TYPE.q`}=$decl;`;
        if ($children_member) {
          my $cdecl = $decl->get_member_by_name($children_member)->get_content_decl;
          my $ctype = $cdecl->get_decl_type;
          if ($ctype == PML_LIST_DECL) {
            my $cmdecl = $cdecl->get_content_decl;
            my $cmdecl_type = $cmdecl->get_decl_type;
            unless ($cmdecl->get_role eq '#NODE' &&
                      ($cmdecl_type == PML_STRUCTURE_DECL or
                         $cmdecl_type == PML_CONTAINER_DECL)) {
              _report_error("List '$path' with role #CHILDNODES may only contain structures or containers with role #NODE in schema '".
                $decl->get_schema->get_url."'; got ".$cmdecl->get_decl_type_str." (".$cmdecl->get_decl_path.") with role '".$cmdecl->get_role."' instead!\n");
            }
            $sub .= q`
            my $content = delete $node->{'`.$children_member.q`'};
            if ($content) {
              my $prev;
              foreach my $son (@{ $content }) {
                if ($prev) {
                  `._paste_last_code(qw($son $prev $node)).q`
                } else {
                  `._paste_first_code(qw($son $node)).q`
                }
                $prev = $son;
              }
            }`;
          } elsif ($ctype == PML_SEQUENCE_DECL) {
            for my $edecl ($cdecl->get_elements) {
              my $cmdecl = $edecl->get_content_decl;
              my $cmdecl_type = $cmdecl->get_decl_type;
              unless ($cmdecl->get_role eq '#NODE' &&
                        ($cmdecl_type == PML_STRUCTURE_DECL or
                           $cmdecl_type == PML_CONTAINER_DECL)) {
                _report_error("Sequence '$path' with role #CHILDNODES may only contain structures or containers with role #NODE in schema '".
                  $decl->get_schema->get_url."'; got ".$cmdecl->get_decl_type_str." (".$cmdecl->get_decl_path.") with role '".$cmdecl->get_role."' instead!\n");
              }
            }
            $sub .= q`
            my $content = delete $node->{'`.$children_member.q`'};
            if ($content) {
              # $content->delegate_names('#name');
              foreach my $element (@{$content->[0]}) { # manually delegate
                $element->[1]{'#name'} = $element->[0]; # store element's name in key $key of its value
              }
              my $prev;
              foreach my $son (map $_->[1], @{$content->[0]}) { # $content->values
                if ($prev) {
                  `._paste_last_code(qw($son $prev $node)).q`
                } else {
                  `._paste_first_code(qw($son $node)).q`
                }
                $prev = $son;
              }
            }`;
          } else {
            _report_error("Role #CHILDNODES can only occur on a structure member of type list or sequence, not on ".$cdecl->get_decl_type_str." '$path' in schema ".$cdecl->get_schema->get_url."\n");
          }
        }
      } else {
        $sub.=q`
         my $node = Treex::PML::Factory->createStructure(\%s,1);
         # my $node = bless \%s, 'Treex::PML::Struct';
       `;
      }
      if (defined $id) {
        $sub.=hash_id_code(qq(\$s{'$id'}),'$node');
      }
      $sub.=q`
         return $node;
       }`;
      # print $sub;
      $src{$src}=$sub;
      $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_CONTAINER_DECL) {
      my %attributes;
      @attributes{ map $_->get_name, $decl->get_attributes } = ();
      my $cdecl = $decl->get_content_decl;
      my $cpath = $cdecl && $cdecl->get_decl_path;
      $cpath=~s/^!// if $cpath;
      my $src = $schema_name.'__generated_read_container@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
       sub {
         my ($p)=@_;
         my $a=$p->[XAT_ATTRS];
         my $c=$p->[XAT_CHILDREN];
         my (%s,$k,$v,$content,@a_rest);
         if ($a) {
           while (@$a) {
             $k=shift @$a;
             $v=shift @$a;
             if (exists $attributes{$k}) {`;
      if ($VALIDATE_CDATA) {
        $sub .= q`
               $s{ $k } = ($handlers{ '`.$path.q`/'.$k }||_unhandled("attribute '$k'",$pml_file,$p,'`.$path.q`'))->( $v );`;
      } else {
        $sub .= q`
               $s{ $k } = $v;`;
      }
      $sub .= q`
             } else {
               push @a_rest, $k, $v;
             }
           }
         }
         $p->[XAT_ATTRS]=\@a_rest;`;
      if ($cdecl) {
        $sub .= q`
         $content = $handlers{ '`.$cpath.q`' }->($p);`;
      } else {
        $sub .= q`
         !$c or !grep { !($_->[XAT_TYPE] == XML_READER_TYPE_WHITESPACE or $_->[XAT_TYPE] == XML_READER_TYPE_SIGNIFICANT_WHITESPACE) } @$c or _report_error(qq(Unexpected content of an empty container type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);`;
      }
      my $id;
      for my $member ($decl->get_attributes) {
        if ($member->is_required) {
          my $name = $member->get_name;
          $sub.=q`
         ref or defined and length or _report_error(q(missing required attribute '`.$name.q`' in container '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]) for $s{'`.$name.q`'};`;
        }
        if ($member->get_role eq '#ID') {
          $id = $member->get_name;
        }
      }
      if ($decl->get_role eq '#NODE' and $BUILD_TREES) {
        $sub .= q`
         my $node = Treex::PML::Factory->createTypedNode($decl,\%s,1);
         # my $node = bless \%s, 'FSNode';
         # $node->{`.$Treex::PML::Node::TYPE.q`}=$decl;`;
        if ($cdecl and ($cdecl->get_role||'') eq '#CHILDNODES') {
          my $ctype = $cdecl->get_decl_type;
          if ($ctype == PML_LIST_DECL) {
            my $cmdecl = $cdecl->get_content_decl;
            my $cmdecl_type = $cmdecl->get_decl_type;
            unless ($cmdecl->get_role eq '#NODE' &&
                      ($cmdecl_type == PML_STRUCTURE_DECL or
                         $cmdecl_type == PML_CONTAINER_DECL)) {
              _report_error("List '$path' with role #CHILDNODES may only contain structures or containers with role #NODE in schema '".
                $decl->get_schema->get_url."'; got ".$cmdecl->get_decl_type_str." (".$cmdecl->get_decl_path.") with role '".$cmdecl->get_role."' instead!\n");
            }
            $sub .= q`
            if ($content) {
              my $prev;
              foreach my $son (@{ $content }) {
                if ($prev) {
                  `._paste_last_code(qw($son $prev $node)).q`
                } else {
                  `._paste_first_code(qw($son $node)).q`
                }
                $prev = $son;
              }
            }`;
          } elsif ($ctype == PML_SEQUENCE_DECL) {
            for my $edecl ($cdecl->get_elements) {
              my $cmdecl = $edecl->get_content_decl or
                _report_error("Element '".$edecl->get_name."' of sequence '$path' has no content type declaration");
              my $cmdecl_type = $cmdecl->get_decl_type;
              unless ($cmdecl->get_role eq '#NODE' &&
                        ($cmdecl_type == PML_STRUCTURE_DECL or
                           $cmdecl_type == PML_CONTAINER_DECL)) {
              _report_error("Sequence '$path' with role #CHILDNODES may only contain structures or containers with role #NODE in schema '".
                $decl->get_schema->get_url."'; got ".$cmdecl->get_decl_type_str." (".$cmdecl->get_decl_path.") with role '".$cmdecl->get_role."' instead!\n");
              }
            }
            $sub .= q`
            if ($content) {
              # $content->delegate_names('#name');
              foreach my $element (@{$content->[0]}) { # manually delegate
                $element->[1]{'#name'} = $element->[0]; # store element's name in key $key of its value
              }
              my $prev;
              foreach my $son (map $_->[1], @{$content->[0]}) { # $content->values
                if ($prev) {
                  `._paste_last_code(qw($son $prev $node)).q`
                } else {
                  `._paste_first_code(qw($son $node)).q`
                }
                $prev = $son;
              }
            }`;
          } else {
            _report_error("Role #CHILDNODES can only occur on a container content type if it is a list or sequence, not on a ".$cdecl->get_decl_type_str." '".$path."' in schema ".$cdecl->get_schema->get_url."\n");
          }
        } elsif ($cdecl) {
          $sub .= q`
         $node->{'#content'} = $content if $content;`;
        }
      } else {
        $sub.=q`
         my $node = Treex::PML::Factory->createContainer($content,\%s,1);
         # $s{'#content'}=$content if $content;
         # my $node = bless \%s, 'Treex::PML::Container';`;
      }
      if (defined $id) {
        $sub.=hash_id_code(qq(\$s{'$id'}),'$node');
      }
      $sub.=q`
         return $node;
       }`;
      #    print $sub;
      $src{$src}=$sub;
      $handlers{$path} = eval($sub); die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_SEQUENCE_DECL) {
      my $src = $schema_name.'__generated_read_sequence@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
       sub {
          my ($p)=@_;
          my $c=$p->[XAT_CHILDREN];
          return undef unless $c and @$c;
          my @seq;
          my $k;
          for my $el (@$c) {
            if (ref($el) and $el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT
                and $el->[XAT_NS] == $pml_ns_index) {
              # print "element: $el->[XAT_NAME]\n";
              $k = $el->[XAT_NAME];
              push @seq, bless [$k, ($handlers{ '`.$path.q`/'.$k }||_unhandled("element '$k'",$pml_file,$el,'`.$path.q`'))->($el)], 'Treex::PML::Seq::Element';`;
      if ($decl->is_mixed) {
        $sub .= q`
            } elsif (!ref($el)) {`;
      $sub .= q`
              push @seq, bless ['#TEXT',$el], 'Treex::PML::Seq::Element';
            } elsif ($el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA
                     or $el->[XAT_TYPE] == XML_READER_TYPE_WHITESPACE or $el->[XAT_TYPE] == XML_READER_TYPE_SIGNIFICANT_WHITESPACE) {
              push @seq, bless ['#TEXT',$el->[XAT_VALUE]], 'Treex::PML::Seq::Element';
            }`;
      } else {
        $sub .= q`
            } elsif (!ref($el) or $el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
               _report_error(q(Unexpected text content in a non-mixed sequence '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
            }`;
      }
      $sub .= q`
          }`;
      my $content_pattern = $decl->get_content_pattern;
      if ($VALIDATE_SEQUENCES and $content_pattern) {
        my $re = Treex::PML::Seq::content_pattern2regexp($content_pattern);
        $sub .= q`
        unless (join('',map '<'.$_->[0].'>',@seq) =~ m{^`.$re.q`$}ox) {
          warn("Sequence content (".join(",",map $_->[0], @seq).") does not follow the pattern `.quotemeta($content_pattern).q` in ".$pml_file.' line '.$p->[XAT_LINE]);
        }`;
      }
      if (!$trees_type and $decl->get_role eq '#TREES' and $BUILD_TREES) {
        $trees_type = $decl;
        $sub .= q`
        unless ($have_trees) {
          $have_trees=1;
          _set_trees_seq($ctxt,$trees_type,\@seq);
          return;
        }`;
      }
      if ($content_pattern) {
        $sub .= q`
        return Treex::PML::Factory->createSeq(\@seq, "`.quotemeta($content_pattern).q`",1);
      }`;
      } else {
        $sub .= q`
        return Treex::PML::Factory->createSeq(\@seq, undef, 1);
      }`;
      }
      $src{$src}=$sub;
      $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_LIST_DECL) {
      #    print $path."\t@".$decl->get_decl_type_str,"\n";
      my $cdecl = $decl->get_content_decl
        or croak("Invalid PML Schema: list type without content: ",$decl->get_decl_path);
      my $cpath = $cdecl->get_decl_path;
      $cpath=~s/^!//;
      my $src = $schema_name.'__generated_read_list@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
       sub {
          my ($p)=@_;
          my $c=$p->[XAT_CHILDREN];
          my $a=$p->[XAT_ATTRS];
          return undef unless $c and @$c or $a and @$a;
          my @list;
          my $singleton = $a && @$a ? 1 : 0;
          unless ($singleton) {
          for my $el (@$c) {
            if (!ref($el) or $el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
               $singleton = 1;
               last;
            } elsif ($el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT) {
               $singleton = 1 if $el->[XAT_NAME] ne 'LM' and $el->[XAT_NS] == $pml_ns_index;
               last;
            }
          }}
          if ($singleton) {
            @list = ($handlers{ '`.$cpath.q`' }->($p));
          } else {
            for my $el (@$c) {
              if (ref($el) and $el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT and $el->[XAT_NS] == $pml_ns_index) {
                $el->[XAT_NAME] eq 'LM' or _report_error(q(Unexpected non-LM element ').$el->[XAT_NAME].q(' in a list: '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
                push @list, $handlers{ '`.$cpath.q`' }->($el);
              } elsif (!ref($el) or $el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
                 _report_error(q(Unexpected text content in a list '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
              }
            }
          }`;
      if (!$trees_type and $decl->get_role eq '#TREES' and $BUILD_TREES) {
        my $cdecl_type = $cdecl->get_decl_type;
        unless ($cdecl && ($cdecl->get_role||'') eq '#NODE' &&
                  ($cdecl_type == PML_STRUCTURE_DECL or
                     $cdecl_type == PML_CONTAINER_DECL)) {
          _report_error("List '$path' with role #TREES may only contain structures or containers with role #NODE in schema ".
            $decl->get_schema->get_url."\n");
        }
        $trees_type = $decl;
        $sub .= q`
          unless ($have_trees) {
            $have_trees = 1;
            $ctxt->{'_pml_trees_type'} = $trees_type;
            $ctxt->{'_trees'} = Treex::PML::Factory->createList(\@list,1);
            return;
          }`;
      }
      $sub .= q`
          return Treex::PML::Factory->createList(\@list,1);
        }`;
      # print $sub;
      $src{$src}=$sub;
      $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_ALT_DECL) {
      # print $path."\t@".$decl->get_decl_type_str,"\n";
      my $cpath = $decl->get_content_decl->get_decl_path;
      $cpath=~s/^!//;
      my $src = $schema_name.'__generated_read_alt@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
       sub {
          my ($p)=@_;
          my $c=$p->[XAT_CHILDREN];
          my $a=$p->[XAT_ATTRS];
          return undef unless $c and @$c or $a and @$a;
          my $singleton = $a && @$a ? 1 : 0;
          unless ($singleton) {
            for my $el (@$c) {
              if (!ref($el) or $el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
                $singleton = 1;
                last;
              } elsif ($el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT and $el->[XAT_NS] == $pml_ns_index) {
                $singleton = 1 if $el->[XAT_NAME] ne 'AM';
                last;
              }
            }
          }
          if ($singleton) {
            return $handlers{ '`.$cpath.q`' }->($p);
          } else {
            my @alt;
            for my $el (@$c) {
              if (ref($el) and $el->[XAT_TYPE] == XML_READER_TYPE_ELEMENT and $el->[XAT_NS] == $pml_ns_index) {
                $el->[XAT_NAME] eq 'AM' or _report_error(q(Unexpected non-AM element ').$el->[XAT_NAME].q(' in an alt: '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
                push @alt, $handlers{ '`.$cpath.q`' }->($el);
              } elsif (!ref($el) or $el->[XAT_TYPE] == XML_READER_TYPE_TEXT or $el->[XAT_TYPE] == XML_READER_TYPE_CDATA) {
                 _report_error(q(Unexpected text content in an alt: '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
              }
            }
            return @alt == 0 ? undef : @alt == 1 ? $alt[0] : 
               #return bless \@alt, 'Treex::PML::Alt';
               Treex::PML::Factory->createAlt(\@alt,1);
          }
       }
    `;
      # print $sub;
      $src{$src}=$sub;
      $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_CDATA_DECL) {
      my $src = $schema_name.'__generated_read_cdata@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
         sub {
            my ($p)=@_;
            my $text;
            if (ref($p)) {
              my $c = $p->[XAT_CHILDREN];
              return undef unless $c and @$c;
              my $type;
              $text = join '',
              map {
                if (ref($_)) {
                  $type = $_->[XAT_TYPE];
                  if ($type == XML_READER_TYPE_TEXT ||
                      $type == XML_READER_TYPE_WHITESPACE ||
                      $type == XML_READER_TYPE_SIGNIFICANT_WHITESPACE ||
                      $type == XML_READER_TYPE_CDATA) {
                    $_->[XAT_VALUE]
                  } elsif ($type == XML_READER_TYPE_ELEMENT) {
                     _report_error(q(Element found where only character data were expected in element <).$_->[XAT_NAME].q(> of CDATA type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
                  }
                } else {
                  $_
                }
              } @$c;`;
      my $format_checker;
      if ($VALIDATE_CDATA and $decl->get_format ne 'any') {
        $sub .=q`
            } else {
              $text = $p;
            }`;
        $format_checker = $decl->_get_format_checker();
        if (defined $format_checker) {
          if (ref($format_checker) eq 'CODE') {
            $sub .= q`
            if (defined $text and length $text and !$format_checker->($text)) {`;
          } else {
            $sub .= q`
            if (defined $text and length $text and $text !~ $format_checker) {`;
          }
          $sub .= q`
              warn("CDATA value '$text' does not conform to format '`.$decl->get_format.q`' at ".$pml_file.' line '.$p->[XAT_LINE]);
            }`;
        }
        $sub .= q`
            return $text;
          }`;
      } else {
        $sub .=q`
              return $text;
            } else {
              return $p;
            }
          }`;
      }
      #    print $sub;
      $src{$src}=$sub;
      $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_CHOICE_DECL) {
      #    print $path,"\n";
      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_read_choice@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
         sub {
            my ($p)=@_;
            my $text;
            if (ref($p)) {
              my $c = $p->[XAT_CHILDREN];
              return undef unless @$c;
              $c=$c->[0];
              if (ref($c)) {
                my $type = $c->[XAT_TYPE];
                if ($type == XML_READER_TYPE_TEXT ||
                    $type == XML_READER_TYPE_WHITESPACE ||
                    $type == XML_READER_TYPE_SIGNIFICANT_WHITESPACE ||
                    $type == XML_READER_TYPE_CDATA) {
                  $text = $c->[XAT_VALUE]
                } elsif ($type == XML_READER_TYPE_ELEMENT) {
                     _report_error(q(Element found where only character data were expected in element <).$p->[XAT_NAME].q(> of choice type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
                }
              } else {
                $text = $c;
              }
            } else {
              $text=$p;
            }
            return undef unless defined $text;
            exists($value_hash->{$text}) or _report_error(qq(Invalid value '$text' in element <).$p->[XAT_NAME].q(> of choice type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
            return $text;
         }`;
      #    print $sub;
      $src{$src}=$sub;
      $handlers{$path} = eval $sub; die _nl($sub)."\n".$@.' ' if $@;
    } elsif ($decl_type == PML_CONSTANT_DECL) {
      #    print $path,"\n";
      my $value = quotemeta($decl->{value});
      my $src = $schema_name.'__generated_read_constant@'.$path;
      $src=~y{/}{@};
      my $sub = q`#line 0 ".pml_compile.d/`.$src.q`"
         sub {
            my ($p)=@_;
            my $text;
            if (ref($p)) {
              my $c = $p->[XAT_CHILDREN];
              return undef unless $c and @$c;
              $c=$c->[0];
              if (ref($c)) {
                my $type = $c->[XAT_TYPE];
                if ($type == XML_READER_TYPE_TEXT ||
                    $type == XML_READER_TYPE_WHITESPACE ||
                    $type == XML_READER_TYPE_SIGNIFICANT_WHITESPACE ||
                    $type == XML_READER_TYPE_CDATA) {
                  $text = $c->[XAT_VALUE]
                } elsif ($type == XML_READER_TYPE_ELEMENT) {
                   _report_error(q(Unexpected element occurrence in element <).$p->[XAT_NAME].q(> of constant type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
                }
              } else {
                $text = $c;
              }
            } else {
              $text=$p;
            }
            !(defined($text) and length($text)) or ($text eq "`.$value.q`") or 
                 _report_error(qq(Invalid value '$text' in element <).$p->[XAT_NAME].q(> of constant type '`.$path.q`' at ).$pml_file.' line '.$p->[XAT_LINE]);
            return $text;
         }`;
      #    print $sub;
      $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 ||
            $decl_type == PML_MEMBER_DECL ||
              $decl_type == PML_ELEMENT_DECL
             ) {
        my $parent = $decl->get_parent_decl;
        my $path = $parent->get_decl_path . '/'. $decl->get_name;
        $path =~ s/^!// if $path;
        my $mdecl;
        if ($decl_type == PML_MEMBER_DECL and $decl->is_required) {
          # a hack that fixes missing content of a required member
          # containing a construct with the role #TREES
          #
          # the modified handler returns string '#TREES' instead
          # and the value gets deleted in the structure handler
          $mdecl = $decl->get_content_decl;
          if ($mdecl->get_role eq '#TREES' and $mdecl==$trees_type) {
            my $mpath = $mdecl->get_decl_path;
            $mpath =~ s/^!// if $mpath;
            my $handler = $handlers{$mpath};
            $handlers{$path}=sub {
              if (!$have_trees and $BUILD_TREES) {
                my $ret = &$handler;
                return '#TREES' if $have_trees and !defined($ret);
                return $ret;
              } else {
                return &$handler;
              }
            };
            return;
          }
        }
        #    print "$path\n";
        if (!exists($handlers{$path})) {
          $mdecl ||= $decl->get_content_decl;
          my $mpath = $mdecl && $mdecl->get_decl_path;
          if ($mpath) {
            $mpath =~ s/^!//;
            #      print "mapping $path -> $mpath ... $handlers{$mpath}\n";
            $handlers{$path} = $handlers{$mpath};
          }
        }
      }
    });
}
sub _nl {
  my ($str)=@_;
  my $i=0;
  return join "\n", map sprintf("%4d\t",$i++).$_, split /\n/, $str;
}
}
{
  # outside the main blog so that we leak no lexicals other than $dom
  sub perl_transform {
    return eval shift();
  }
}
1;
__END__
HideShow 55 lines of Pod
=head1 NAME
Treex::PML::Instance::Reader
=head1 DESCRIPTION
This module provides implements the load() method of
L<Treex::PML::Instance> and is not intended for direct use.
=head1 IMPLEMENTATION NOTES
The module analyses a L<Treex::PML::Schema> and generates Perl code to
parse PML instances conforming to that schema (by generating handlers
for individual data types). L<XML::CompactTree::XS> (or
L<XML::CompactTree>) is used to first slurp the XML into in-memory
Perl data structures (much faster than using SAX, XML::LibXML::Reader,
DOM, or any other parsing strategy known). The Perl code generated by
this module transforms these data structures into the coresponding
L<Treex::PML> objects.
The handlers for last 50 PML schemas are cached in memory, to boost
processing large collections of PML instances conforming to only a few
distinct schemas.
The module also implements automatic pluggable XSLT, external command,
or Perl pre-processing (transformation) of the input document; this
pre-processing can be specified in a configuration file
(C<pmlbackend_conf.xml>, see L<Treex::PML::Instance/"CONFIGURATION">
for more details).
=head1 DEBUGGING
If the environment variable PML_COMPILE_DUMP=1 is set, the module
dumps the generated code to the C<.pml_compile.d/> folder in the
current working directory. This is very for debugging or profiling the
generated code.
=head1 SEE ALSO
L<Treex::PML::Instance>, L<Treex::PML::Instance::Writer>,
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2008-2010 by Petr Pajas
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.2 or,
at your option, any later version of Perl 5 you may have available.
=head1 BUGS
None reported... yet.
=cut